From: Ximin Luo Date: Sun, 6 Nov 2016 18:47:52 +0000 (+0100) Subject: New upstream version 4.04.0 X-Git-Tag: archive/raspbian/4.08.1-4+rpi1~3^2~63^2~2 X-Git-Url: https://dgit.raspbian.org/?a=commitdiff_plain;h=648a1457a7d1d9989f3df5e52902ee4e02f3052c;p=ocaml.git New upstream version 4.04.0 --- diff --git a/.depend b/.depend index 43f0a1c6..45132604 100644 --- a/.depend +++ b/.depend @@ -1,87 +1,68 @@ +utils/arg_helper.cmo : utils/arg_helper.cmi +utils/arg_helper.cmx : utils/arg_helper.cmi utils/arg_helper.cmi : -utils/ccomp.cmi : -utils/clflags.cmi : utils/misc.cmi -utils/config.cmi : -utils/consistbl.cmi : -utils/identifiable.cmi : -utils/misc.cmi : -utils/numbers.cmi : utils/identifiable.cmi -utils/strongly_connected_components.cmi : utils/identifiable.cmi -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/ccomp.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/clflags.cmi : utils/misc.cmi utils/config.cmo : utils/config.cmi utils/config.cmx : utils/config.cmi +utils/config.cmi : utils/consistbl.cmo : utils/consistbl.cmi utils/consistbl.cmx : utils/consistbl.cmi +utils/consistbl.cmi : utils/identifiable.cmo : utils/misc.cmi utils/identifiable.cmi utils/identifiable.cmx : utils/misc.cmx utils/identifiable.cmi +utils/identifiable.cmi : utils/misc.cmo : utils/misc.cmi utils/misc.cmx : utils/misc.cmi +utils/misc.cmi : utils/numbers.cmo : utils/identifiable.cmi utils/numbers.cmi utils/numbers.cmx : utils/identifiable.cmx utils/numbers.cmi +utils/numbers.cmi : utils/identifiable.cmi utils/strongly_connected_components.cmo : utils/numbers.cmi utils/misc.cmi \ utils/identifiable.cmi utils/strongly_connected_components.cmi utils/strongly_connected_components.cmx : utils/numbers.cmx utils/misc.cmx \ utils/identifiable.cmx utils/strongly_connected_components.cmi +utils/strongly_connected_components.cmi : utils/identifiable.cmi utils/tbl.cmo : utils/tbl.cmi utils/tbl.cmx : utils/tbl.cmi +utils/tbl.cmi : utils/terminfo.cmo : utils/terminfo.cmi utils/terminfo.cmx : utils/terminfo.cmi +utils/terminfo.cmi : utils/timings.cmo : utils/timings.cmi utils/timings.cmx : utils/timings.cmi +utils/timings.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_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 -parsing/longident.cmi : -parsing/parse.cmi : parsing/parsetree.cmi -parsing/parser.cmi : parsing/parsetree.cmi parsing/location.cmi \ - parsing/docstrings.cmi -parsing/parsetree.cmi : parsing/longident.cmi parsing/location.cmi \ - parsing/asttypes.cmi -parsing/pprintast.cmi : parsing/parsetree.cmi parsing/longident.cmi \ - parsing/asttypes.cmi -parsing/printast.cmi : parsing/parsetree.cmi -parsing/syntaxerr.cmi : parsing/location.cmi +utils/warnings.cmi : parsing/ast_helper.cmo : parsing/parsetree.cmi parsing/longident.cmi \ parsing/location.cmi parsing/docstrings.cmi parsing/asttypes.cmi \ parsing/ast_helper.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_helper.cmi : parsing/parsetree.cmi parsing/longident.cmi \ + parsing/location.cmi parsing/docstrings.cmi parsing/asttypes.cmi parsing/ast_invariants.cmo : parsing/syntaxerr.cmi parsing/parsetree.cmi \ parsing/longident.cmi parsing/builtin_attributes.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/builtin_attributes.cmx parsing/asttypes.cmi \ parsing/ast_iterator.cmx parsing/ast_invariants.cmi +parsing/ast_invariants.cmi : parsing/parsetree.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_iterator.cmi : parsing/parsetree.cmi parsing/location.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 \ @@ -90,36 +71,54 @@ parsing/ast_mapper.cmx : parsing/parsetree.cmi utils/misc.cmx \ parsing/longident.cmx parsing/location.cmx utils/config.cmx \ utils/clflags.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \ parsing/ast_mapper.cmi +parsing/ast_mapper.cmi : parsing/parsetree.cmi parsing/location.cmi +parsing/asttypes.cmi : parsing/location.cmi parsing/attr_helper.cmo : parsing/parsetree.cmi parsing/location.cmi \ parsing/asttypes.cmi parsing/attr_helper.cmi parsing/attr_helper.cmx : parsing/parsetree.cmi parsing/location.cmx \ parsing/asttypes.cmi parsing/attr_helper.cmi +parsing/attr_helper.cmi : parsing/parsetree.cmi parsing/location.cmi \ + parsing/asttypes.cmi parsing/builtin_attributes.cmo : utils/warnings.cmi parsing/parsetree.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_iterator.cmx \ parsing/builtin_attributes.cmi +parsing/builtin_attributes.cmi : parsing/parsetree.cmi parsing/location.cmi \ + parsing/ast_iterator.cmi +parsing/depend.cmo : parsing/parsetree.cmi utils/misc.cmi \ + parsing/longident.cmi parsing/location.cmi utils/clflags.cmi \ + parsing/builtin_attributes.cmi parsing/asttypes.cmi parsing/depend.cmi +parsing/depend.cmx : parsing/parsetree.cmi utils/misc.cmx \ + parsing/longident.cmx parsing/location.cmx utils/clflags.cmx \ + parsing/builtin_attributes.cmx parsing/asttypes.cmi parsing/depend.cmi +parsing/depend.cmi : parsing/parsetree.cmi parsing/longident.cmi parsing/docstrings.cmo : utils/warnings.cmi parsing/parsetree.cmi \ parsing/location.cmi parsing/docstrings.cmi parsing/docstrings.cmx : utils/warnings.cmx parsing/parsetree.cmi \ parsing/location.cmx parsing/docstrings.cmi +parsing/docstrings.cmi : parsing/parsetree.cmi parsing/location.cmi parsing/lexer.cmo : utils/warnings.cmi parsing/parser.cmi utils/misc.cmi \ parsing/location.cmi parsing/docstrings.cmi parsing/lexer.cmi parsing/lexer.cmx : utils/warnings.cmx parsing/parser.cmx utils/misc.cmx \ parsing/location.cmx parsing/docstrings.cmx parsing/lexer.cmi +parsing/lexer.cmi : parsing/parser.cmi parsing/location.cmi parsing/location.cmo : utils/warnings.cmi utils/terminfo.cmi utils/misc.cmi \ utils/clflags.cmi parsing/location.cmi parsing/location.cmx : utils/warnings.cmx utils/terminfo.cmx utils/misc.cmx \ utils/clflags.cmx parsing/location.cmi +parsing/location.cmi : utils/warnings.cmi parsing/longident.cmo : utils/misc.cmi parsing/longident.cmi parsing/longident.cmx : utils/misc.cmx parsing/longident.cmi +parsing/longident.cmi : parsing/parse.cmo : parsing/syntaxerr.cmi parsing/parser.cmi \ parsing/location.cmi parsing/lexer.cmi parsing/docstrings.cmi \ parsing/parse.cmi parsing/parse.cmx : parsing/syntaxerr.cmx parsing/parser.cmx \ parsing/location.cmx parsing/lexer.cmx parsing/docstrings.cmx \ parsing/parse.cmi +parsing/parse.cmi : parsing/parsetree.cmi parsing/parser.cmo : parsing/syntaxerr.cmi parsing/parsetree.cmi \ parsing/longident.cmi parsing/location.cmi parsing/docstrings.cmi \ utils/clflags.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \ @@ -128,95 +127,38 @@ parsing/parser.cmx : parsing/syntaxerr.cmx parsing/parsetree.cmi \ parsing/longident.cmx parsing/location.cmx parsing/docstrings.cmx \ utils/clflags.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \ parsing/parser.cmi +parsing/parser.cmi : parsing/parsetree.cmi parsing/location.cmi \ + parsing/docstrings.cmi +parsing/parsetree.cmi : parsing/longident.cmi parsing/location.cmi \ + parsing/asttypes.cmi parsing/pprintast.cmo : parsing/parsetree.cmi utils/misc.cmi \ parsing/longident.cmi parsing/location.cmi parsing/asttypes.cmi \ parsing/pprintast.cmi parsing/pprintast.cmx : parsing/parsetree.cmi utils/misc.cmx \ parsing/longident.cmx parsing/location.cmx parsing/asttypes.cmi \ parsing/pprintast.cmi +parsing/pprintast.cmi : parsing/parsetree.cmi parsing/printast.cmo : parsing/parsetree.cmi utils/misc.cmi \ parsing/longident.cmi parsing/location.cmi parsing/asttypes.cmi \ parsing/printast.cmi parsing/printast.cmx : parsing/parsetree.cmi utils/misc.cmx \ parsing/longident.cmx parsing/location.cmx parsing/asttypes.cmi \ parsing/printast.cmi +parsing/printast.cmi : parsing/parsetree.cmi parsing/syntaxerr.cmo : parsing/location.cmi parsing/syntaxerr.cmi parsing/syntaxerr.cmx : parsing/location.cmx parsing/syntaxerr.cmi +parsing/syntaxerr.cmi : parsing/location.cmi typing/annot.cmi : parsing/location.cmi -typing/btype.cmi : typing/types.cmi typing/path.cmi parsing/asttypes.cmi -typing/cmi_format.cmi : typing/types.cmi -typing/cmt_format.cmi : typing/types.cmi typing/typedtree.cmi \ - parsing/location.cmi typing/env.cmi typing/cmi_format.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/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 \ - typing/ident.cmi typing/env.cmi -typing/includemod.cmi : typing/types.cmi typing/typedtree.cmi \ - typing/path.cmi parsing/location.cmi typing/includecore.cmi \ - typing/ident.cmi typing/env.cmi typing/ctype.cmi -typing/mtype.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi \ - typing/env.cmi -typing/oprint.cmi : typing/outcometree.cmi -typing/outcometree.cmi : parsing/asttypes.cmi -typing/parmatch.cmi : typing/types.cmi typing/typedtree.cmi \ - parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ - typing/env.cmi parsing/asttypes.cmi -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/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 -typing/tast_mapper.cmi : typing/typedtree.cmi typing/env.cmi \ - parsing/asttypes.cmi -typing/typeclass.cmi : typing/types.cmi typing/typedtree.cmi \ - parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ - typing/ident.cmi typing/env.cmi typing/ctype.cmi parsing/asttypes.cmi -typing/typecore.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ - parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ - typing/ident.cmi typing/env.cmi parsing/asttypes.cmi typing/annot.cmi -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/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 \ - parsing/asttypes.cmi -typing/types.cmi : typing/primitive.cmi typing/path.cmi \ - parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ - typing/ident.cmi parsing/asttypes.cmi -typing/typetexp.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ - parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ - typing/env.cmi parsing/asttypes.cmi -typing/untypeast.cmi : typing/typedtree.cmi typing/path.cmi \ - parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ - parsing/asttypes.cmi typing/btype.cmo : typing/types.cmi typing/path.cmi utils/misc.cmi \ typing/ident.cmi parsing/asttypes.cmi typing/btype.cmi typing/btype.cmx : typing/types.cmx typing/path.cmx utils/misc.cmx \ typing/ident.cmx parsing/asttypes.cmi typing/btype.cmi +typing/btype.cmi : typing/types.cmi typing/path.cmi parsing/asttypes.cmi typing/cmi_format.cmo : typing/types.cmi parsing/location.cmi \ utils/config.cmi typing/cmi_format.cmi typing/cmi_format.cmx : typing/types.cmx parsing/location.cmx \ utils/config.cmx typing/cmi_format.cmi +typing/cmi_format.cmi : typing/types.cmi typing/cmt_format.cmo : typing/types.cmi typing/typedtree.cmi \ typing/tast_mapper.cmi utils/misc.cmi parsing/location.cmi \ parsing/lexer.cmi typing/env.cmi utils/config.cmi typing/cmi_format.cmi \ @@ -225,6 +167,8 @@ typing/cmt_format.cmx : typing/types.cmx typing/typedtree.cmx \ typing/tast_mapper.cmx utils/misc.cmx parsing/location.cmx \ parsing/lexer.cmx typing/env.cmx utils/config.cmx typing/cmi_format.cmx \ utils/clflags.cmx typing/cmt_format.cmi +typing/cmt_format.cmi : typing/types.cmi typing/typedtree.cmi \ + parsing/location.cmi typing/env.cmi typing/cmi_format.cmi typing/ctype.cmo : typing/types.cmi typing/subst.cmi typing/predef.cmi \ typing/path.cmi utils/misc.cmi parsing/longident.cmi parsing/location.cmi \ typing/ident.cmi typing/env.cmi utils/clflags.cmi typing/btype.cmi \ @@ -233,12 +177,15 @@ typing/ctype.cmx : typing/types.cmx typing/subst.cmx typing/predef.cmx \ typing/path.cmx utils/misc.cmx parsing/longident.cmx parsing/location.cmx \ typing/ident.cmx typing/env.cmx utils/clflags.cmx typing/btype.cmx \ parsing/asttypes.cmi typing/ctype.cmi +typing/ctype.cmi : typing/types.cmi typing/path.cmi parsing/longident.cmi \ + typing/ident.cmi typing/env.cmi parsing/asttypes.cmi typing/datarepr.cmo : typing/types.cmi typing/path.cmi parsing/location.cmi \ typing/ident.cmi typing/btype.cmi parsing/asttypes.cmi \ typing/datarepr.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/datarepr.cmi : typing/types.cmi typing/path.cmi typing/ident.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 \ @@ -251,26 +198,33 @@ 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/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 typing/cmi_format.cmi \ + parsing/asttypes.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/envaux.cmi : typing/subst.cmi typing/path.cmi typing/env.cmi typing/ident.cmo : utils/identifiable.cmi typing/ident.cmi typing/ident.cmx : utils/identifiable.cmx typing/ident.cmi +typing/ident.cmi : utils/identifiable.cmi typing/includeclass.cmo : typing/types.cmi typing/printtyp.cmi \ typing/ctype.cmi typing/includeclass.cmi typing/includeclass.cmx : typing/types.cmx typing/printtyp.cmx \ typing/ctype.cmx typing/includeclass.cmi +typing/includeclass.cmi : typing/types.cmi typing/env.cmi typing/ctype.cmi typing/includecore.cmo : typing/types.cmi typing/typedtree.cmi \ - typing/path.cmi utils/misc.cmi typing/ident.cmi typing/env.cmi \ - typing/ctype.cmi typing/btype.cmi parsing/asttypes.cmi \ - typing/includecore.cmi + typing/path.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \ + typing/btype.cmi parsing/asttypes.cmi typing/includecore.cmi typing/includecore.cmx : typing/types.cmx typing/typedtree.cmx \ - typing/path.cmx utils/misc.cmx typing/ident.cmx typing/env.cmx \ - typing/ctype.cmx typing/btype.cmx parsing/asttypes.cmi \ - typing/includecore.cmi + typing/path.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \ + typing/btype.cmx parsing/asttypes.cmi typing/includecore.cmi +typing/includecore.cmi : typing/types.cmi typing/typedtree.cmi \ + typing/ident.cmi typing/env.cmi typing/includemod.cmo : typing/types.cmi typing/typedtree.cmi utils/tbl.cmi \ typing/subst.cmi typing/printtyp.cmi typing/primitive.cmi typing/path.cmi \ typing/mtype.cmi utils/misc.cmi parsing/location.cmi \ @@ -283,6 +237,9 @@ typing/includemod.cmx : typing/types.cmx typing/typedtree.cmx utils/tbl.cmx \ typing/includecore.cmx typing/includeclass.cmx typing/ident.cmx \ typing/env.cmx typing/ctype.cmx typing/cmt_format.cmx utils/clflags.cmx \ typing/includemod.cmi +typing/includemod.cmi : typing/types.cmi typing/typedtree.cmi \ + typing/path.cmi parsing/location.cmi typing/includecore.cmi \ + typing/ident.cmi typing/env.cmi typing/ctype.cmi typing/mtype.cmo : typing/types.cmi typing/subst.cmi typing/path.cmi \ utils/misc.cmi parsing/location.cmi typing/ident.cmi typing/env.cmi \ typing/ctype.cmi utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ @@ -291,10 +248,14 @@ typing/mtype.cmx : typing/types.cmx typing/subst.cmx typing/path.cmx \ utils/misc.cmx parsing/location.cmx typing/ident.cmx typing/env.cmx \ typing/ctype.cmx utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ typing/mtype.cmi +typing/mtype.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi \ + typing/env.cmi typing/oprint.cmo : typing/outcometree.cmi parsing/asttypes.cmi \ typing/oprint.cmi typing/oprint.cmx : typing/outcometree.cmi parsing/asttypes.cmi \ typing/oprint.cmi +typing/oprint.cmi : typing/outcometree.cmi +typing/outcometree.cmi : parsing/asttypes.cmi typing/parmatch.cmo : utils/warnings.cmi typing/untypeast.cmi \ typing/types.cmi typing/typedtreeIter.cmi typing/typedtree.cmi \ typing/subst.cmi typing/predef.cmi typing/path.cmi parsing/parsetree.cmi \ @@ -307,52 +268,70 @@ typing/parmatch.cmx : utils/warnings.cmx typing/untypeast.cmx \ utils/misc.cmx parsing/longident.cmx parsing/location.cmx \ typing/ident.cmx typing/env.cmx typing/ctype.cmx typing/btype.cmx \ parsing/asttypes.cmi parsing/ast_helper.cmx typing/parmatch.cmi +typing/parmatch.cmi : typing/types.cmi typing/typedtree.cmi \ + parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ + typing/env.cmi parsing/asttypes.cmi typing/path.cmo : typing/ident.cmi typing/path.cmi typing/path.cmx : typing/ident.cmx typing/path.cmi +typing/path.cmi : typing/ident.cmi typing/predef.cmo : typing/types.cmi typing/path.cmi parsing/parsetree.cmi \ parsing/location.cmi typing/ident.cmi typing/btype.cmi \ parsing/asttypes.cmi typing/predef.cmi typing/predef.cmx : typing/types.cmx typing/path.cmx parsing/parsetree.cmi \ parsing/location.cmx typing/ident.cmx typing/btype.cmx \ parsing/asttypes.cmi typing/predef.cmi +typing/predef.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi typing/primitive.cmo : utils/warnings.cmi parsing/parsetree.cmi \ typing/outcometree.cmi utils/misc.cmi parsing/location.cmi \ parsing/attr_helper.cmi typing/primitive.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/primitive.cmi : parsing/parsetree.cmi typing/outcometree.cmi \ + parsing/location.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 \ parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ - typing/env.cmi typing/ctype.cmi utils/clflags.cmi typing/btype.cmi \ - parsing/asttypes.cmi typing/printtyp.cmi + typing/env.cmi typing/ctype.cmi utils/clflags.cmi \ + parsing/builtin_attributes.cmi typing/btype.cmi parsing/asttypes.cmi \ + typing/printtyp.cmi typing/printtyp.cmx : typing/types.cmx typing/primitive.cmx \ typing/predef.cmx typing/path.cmx parsing/parsetree.cmi \ typing/outcometree.cmi typing/oprint.cmx utils/misc.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/env.cmx typing/ctype.cmx utils/clflags.cmx \ + parsing/builtin_attributes.cmx typing/btype.cmx parsing/asttypes.cmi \ + typing/printtyp.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.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/printtyped.cmi : typing/typedtree.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 \ parsing/location.cmx utils/clflags.cmx typing/annot.cmi typing/stypes.cmi +typing/stypes.cmi : typing/typedtree.cmi parsing/location.cmi \ + typing/annot.cmi typing/subst.cmo : typing/types.cmi utils/tbl.cmi typing/path.cmi \ utils/misc.cmi parsing/location.cmi typing/ident.cmi utils/clflags.cmi \ typing/btype.cmi parsing/ast_mapper.cmi typing/subst.cmi typing/subst.cmx : typing/types.cmx utils/tbl.cmx typing/path.cmx \ utils/misc.cmx parsing/location.cmx typing/ident.cmx utils/clflags.cmx \ typing/btype.cmx parsing/ast_mapper.cmx typing/subst.cmi +typing/subst.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi typing/tast_mapper.cmo : typing/typedtree.cmi typing/env.cmi \ parsing/asttypes.cmi typing/tast_mapper.cmi typing/tast_mapper.cmx : typing/typedtree.cmx typing/env.cmx \ parsing/asttypes.cmi typing/tast_mapper.cmi +typing/tast_mapper.cmi : typing/typedtree.cmi typing/env.cmi \ + parsing/asttypes.cmi typing/typeclass.cmo : utils/warnings.cmi typing/typetexp.cmi \ typing/types.cmi typing/typedtree.cmi typing/typedecl.cmi \ typing/typecore.cmi typing/subst.cmi typing/stypes.cmi \ @@ -371,42 +350,54 @@ typing/typeclass.cmx : utils/warnings.cmx typing/typetexp.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/typeclass.cmi : typing/types.cmi typing/typedtree.cmi \ + parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ + typing/ident.cmi typing/env.cmi typing/ctype.cmi parsing/asttypes.cmi typing/typecore.cmo : utils/warnings.cmi typing/typetexp.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/types.cmi typing/typedtree.cmi typing/typedecl.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 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/typedecl.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/typecore.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ + parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ + typing/ident.cmi typing/env.cmi parsing/asttypes.cmi typing/annot.cmi typing/typedecl.cmo : utils/warnings.cmi typing/typetexp.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_iterator.cmi parsing/ast_helper.cmi \ - typing/typedecl.cmi + typing/ident.cmi typing/env.cmi typing/datarepr.cmi typing/ctype.cmi \ + utils/config.cmi utils/clflags.cmi parsing/builtin_attributes.cmi \ + typing/btype.cmi parsing/attr_helper.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 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_iterator.cmx parsing/ast_helper.cmx \ - typing/typedecl.cmi + typing/ident.cmx typing/env.cmx typing/datarepr.cmx typing/ctype.cmx \ + utils/config.cmx utils/clflags.cmx parsing/builtin_attributes.cmx \ + typing/btype.cmx parsing/attr_helper.cmx parsing/asttypes.cmi \ + parsing/ast_iterator.cmx parsing/ast_helper.cmx typing/typedecl.cmi +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/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 \ @@ -415,14 +406,19 @@ 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/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.cmo : typing/typedtree.cmi utils/misc.cmi \ parsing/asttypes.cmi typing/typedtreeIter.cmi typing/typedtreeIter.cmx : typing/typedtree.cmx utils/misc.cmx \ parsing/asttypes.cmi typing/typedtreeIter.cmi +typing/typedtreeIter.cmi : typing/typedtree.cmi parsing/asttypes.cmi typing/typedtreeMap.cmo : typing/typedtree.cmi utils/misc.cmi \ typing/typedtreeMap.cmi typing/typedtreeMap.cmx : typing/typedtree.cmx utils/misc.cmx \ typing/typedtreeMap.cmi +typing/typedtreeMap.cmi : typing/typedtree.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 \ @@ -443,12 +439,19 @@ typing/typemod.cmx : utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \ utils/clflags.cmx parsing/builtin_attributes.cmx typing/btype.cmx \ parsing/asttypes.cmi parsing/ast_iterator.cmx typing/annot.cmi \ typing/typemod.cmi +typing/typemod.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ + parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \ + parsing/location.cmi typing/includemod.cmi typing/ident.cmi \ + typing/env.cmi parsing/asttypes.cmi typing/types.cmo : typing/primitive.cmi typing/path.cmi \ parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ typing/ident.cmi parsing/asttypes.cmi typing/types.cmi 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/types.cmi : typing/primitive.cmi typing/path.cmi \ + parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ + typing/ident.cmi parsing/asttypes.cmi typing/typetexp.cmo : utils/warnings.cmi typing/types.cmi \ typing/typedtree.cmi utils/tbl.cmi typing/printtyp.cmi typing/predef.cmi \ typing/path.cmi parsing/parsetree.cmi utils/misc.cmi \ @@ -463,6 +466,9 @@ typing/typetexp.cmx : utils/warnings.cmx typing/types.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/typetexp.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ + parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ + typing/env.cmi parsing/asttypes.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 \ @@ -471,41 +477,9 @@ typing/untypeast.cmx : typing/typedtree.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 \ parsing/ast_helper.cmx typing/untypeast.cmi -bytecomp/bytegen.cmi : bytecomp/lambda.cmi bytecomp/instruct.cmi -bytecomp/bytelibrarian.cmi : -bytecomp/bytelink.cmi : bytecomp/symtable.cmi bytecomp/cmo_format.cmi -bytecomp/bytepackager.cmi : typing/ident.cmi typing/env.cmi -bytecomp/bytesections.cmi : -bytecomp/cmo_format.cmi : bytecomp/lambda.cmi typing/ident.cmi -bytecomp/debuginfo.cmi : parsing/location.cmi bytecomp/lambda.cmi -bytecomp/dll.cmi : -bytecomp/emitcode.cmi : bytecomp/instruct.cmi bytecomp/cmo_format.cmi -bytecomp/instruct.cmi : typing/types.cmi typing/subst.cmi \ - parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi -bytecomp/lambda.cmi : typing/types.cmi typing/primitive.cmi typing/path.cmi \ - parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi -bytecomp/matching.cmi : typing/typedtree.cmi parsing/location.cmi \ - bytecomp/lambda.cmi typing/ident.cmi -bytecomp/meta.cmi : bytecomp/instruct.cmi -bytecomp/printinstr.cmi : bytecomp/instruct.cmi -bytecomp/printlambda.cmi : bytecomp/lambda.cmi -bytecomp/runtimedef.cmi : -bytecomp/simplif.cmi : bytecomp/lambda.cmi typing/ident.cmi -bytecomp/switch.cmi : -bytecomp/symtable.cmi : utils/misc.cmi typing/ident.cmi \ - bytecomp/cmo_format.cmi -bytecomp/translattribute.cmi : typing/typedtree.cmi parsing/parsetree.cmi \ - parsing/location.cmi bytecomp/lambda.cmi -bytecomp/translclass.cmi : typing/typedtree.cmi parsing/location.cmi \ - bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi -bytecomp/translcore.cmi : typing/types.cmi typing/typedtree.cmi \ - typing/primitive.cmi typing/path.cmi parsing/location.cmi \ - bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi -bytecomp/translmod.cmi : typing/typedtree.cmi typing/primitive.cmi \ - parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi -bytecomp/translobj.cmi : bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi -bytecomp/typeopt.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ - bytecomp/lambda.cmi typing/env.cmi +typing/untypeast.cmi : typing/typedtree.cmi typing/path.cmi \ + parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ + parsing/asttypes.cmi bytecomp/bytegen.cmo : typing/types.cmi bytecomp/switch.cmi typing/subst.cmi \ typing/primitive.cmi utils/misc.cmi bytecomp/matching.cmi \ bytecomp/lambda.cmi bytecomp/instruct.cmi typing/ident.cmi \ @@ -514,24 +488,27 @@ bytecomp/bytegen.cmx : typing/types.cmx bytecomp/switch.cmx typing/subst.cmx \ typing/primitive.cmx utils/misc.cmx bytecomp/matching.cmx \ bytecomp/lambda.cmx bytecomp/instruct.cmx typing/ident.cmx \ utils/config.cmx parsing/asttypes.cmi bytecomp/bytegen.cmi +bytecomp/bytegen.cmi : bytecomp/lambda.cmi bytecomp/instruct.cmi bytecomp/bytelibrarian.cmo : utils/misc.cmi parsing/location.cmi \ utils/config.cmi bytecomp/cmo_format.cmi utils/clflags.cmi \ bytecomp/bytelink.cmi bytecomp/bytelibrarian.cmi bytecomp/bytelibrarian.cmx : utils/misc.cmx parsing/location.cmx \ utils/config.cmx bytecomp/cmo_format.cmi utils/clflags.cmx \ bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmi +bytecomp/bytelibrarian.cmi : bytecomp/bytelink.cmo : utils/warnings.cmi bytecomp/symtable.cmi \ bytecomp/opcodes.cmo utils/misc.cmi parsing/location.cmi \ - bytecomp/lambda.cmi bytecomp/instruct.cmi bytecomp/dll.cmi \ - utils/consistbl.cmi utils/config.cmi bytecomp/cmo_format.cmi \ - utils/clflags.cmi utils/ccomp.cmi bytecomp/bytesections.cmi \ - bytecomp/bytelink.cmi + bytecomp/lambda.cmi bytecomp/instruct.cmi typing/ident.cmi \ + bytecomp/dll.cmi utils/consistbl.cmi utils/config.cmi \ + bytecomp/cmo_format.cmi utils/clflags.cmi utils/ccomp.cmi \ + bytecomp/bytesections.cmi bytecomp/bytelink.cmi bytecomp/bytelink.cmx : utils/warnings.cmx bytecomp/symtable.cmx \ bytecomp/opcodes.cmx utils/misc.cmx parsing/location.cmx \ - bytecomp/lambda.cmx bytecomp/instruct.cmx bytecomp/dll.cmx \ - utils/consistbl.cmx utils/config.cmx bytecomp/cmo_format.cmi \ - utils/clflags.cmx utils/ccomp.cmx bytecomp/bytesections.cmx \ - bytecomp/bytelink.cmi + bytecomp/lambda.cmx bytecomp/instruct.cmx typing/ident.cmx \ + bytecomp/dll.cmx utils/consistbl.cmx utils/config.cmx \ + bytecomp/cmo_format.cmi utils/clflags.cmx utils/ccomp.cmx \ + bytecomp/bytesections.cmx bytecomp/bytelink.cmi +bytecomp/bytelink.cmi : bytecomp/symtable.cmi bytecomp/cmo_format.cmi bytecomp/bytepackager.cmo : typing/typemod.cmi bytecomp/translmod.cmi \ typing/subst.cmi bytecomp/printlambda.cmi typing/path.cmi utils/misc.cmi \ parsing/location.cmi bytecomp/instruct.cmi typing/ident.cmi \ @@ -544,36 +521,44 @@ bytecomp/bytepackager.cmx : typing/typemod.cmx bytecomp/translmod.cmx \ typing/env.cmx bytecomp/emitcode.cmx utils/config.cmx \ bytecomp/cmo_format.cmi utils/clflags.cmx bytecomp/bytelink.cmx \ bytecomp/bytegen.cmx bytecomp/bytepackager.cmi +bytecomp/bytepackager.cmi : typing/ident.cmi typing/env.cmi bytecomp/bytesections.cmo : utils/config.cmi bytecomp/bytesections.cmi bytecomp/bytesections.cmx : utils/config.cmx bytecomp/bytesections.cmi -bytecomp/debuginfo.cmo : parsing/location.cmi bytecomp/lambda.cmi \ - bytecomp/debuginfo.cmi -bytecomp/debuginfo.cmx : parsing/location.cmx bytecomp/lambda.cmx \ - bytecomp/debuginfo.cmi +bytecomp/bytesections.cmi : +bytecomp/cmo_format.cmi : bytecomp/lambda.cmi typing/ident.cmi bytecomp/dll.cmo : utils/misc.cmi utils/config.cmi bytecomp/dll.cmi bytecomp/dll.cmx : utils/misc.cmx utils/config.cmx bytecomp/dll.cmi +bytecomp/dll.cmi : bytecomp/emitcode.cmo : bytecomp/translmod.cmi typing/primitive.cmi \ bytecomp/opcodes.cmo utils/misc.cmi bytecomp/meta.cmi \ parsing/location.cmi bytecomp/lambda.cmi bytecomp/instruct.cmi \ - typing/env.cmi utils/config.cmi bytecomp/cmo_format.cmi utils/clflags.cmi \ - typing/btype.cmi parsing/asttypes.cmi bytecomp/emitcode.cmi + typing/ident.cmi typing/env.cmi utils/config.cmi bytecomp/cmo_format.cmi \ + utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ + bytecomp/emitcode.cmi bytecomp/emitcode.cmx : bytecomp/translmod.cmx typing/primitive.cmx \ bytecomp/opcodes.cmx utils/misc.cmx bytecomp/meta.cmx \ parsing/location.cmx bytecomp/lambda.cmx bytecomp/instruct.cmx \ - typing/env.cmx utils/config.cmx bytecomp/cmo_format.cmi utils/clflags.cmx \ - typing/btype.cmx parsing/asttypes.cmi bytecomp/emitcode.cmi + typing/ident.cmx typing/env.cmx utils/config.cmx bytecomp/cmo_format.cmi \ + utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ + bytecomp/emitcode.cmi +bytecomp/emitcode.cmi : bytecomp/instruct.cmi typing/ident.cmi \ + bytecomp/cmo_format.cmi bytecomp/instruct.cmo : typing/types.cmi typing/subst.cmi \ parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \ bytecomp/instruct.cmi bytecomp/instruct.cmx : typing/types.cmx typing/subst.cmx \ parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \ bytecomp/instruct.cmi +bytecomp/instruct.cmi : typing/types.cmi typing/subst.cmi \ + parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi bytecomp/lambda.cmo : typing/types.cmi typing/primitive.cmi typing/path.cmi \ utils/misc.cmi parsing/location.cmi typing/ident.cmi typing/env.cmi \ parsing/asttypes.cmi bytecomp/lambda.cmi bytecomp/lambda.cmx : typing/types.cmx typing/primitive.cmx typing/path.cmx \ utils/misc.cmx parsing/location.cmx typing/ident.cmx typing/env.cmx \ parsing/asttypes.cmi bytecomp/lambda.cmi +bytecomp/lambda.cmi : typing/types.cmi typing/primitive.cmi typing/path.cmi \ + parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi bytecomp/matching.cmo : typing/types.cmi bytecomp/typeopt.cmi \ typing/typedtree.cmi bytecomp/switch.cmi bytecomp/printlambda.cmi \ typing/primitive.cmi typing/predef.cmi typing/path.cmi \ @@ -588,8 +573,11 @@ bytecomp/matching.cmx : typing/types.cmx bytecomp/typeopt.cmx \ parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \ utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ bytecomp/matching.cmi +bytecomp/matching.cmi : typing/typedtree.cmi parsing/location.cmi \ + bytecomp/lambda.cmi typing/ident.cmi bytecomp/meta.cmo : bytecomp/instruct.cmi bytecomp/meta.cmi bytecomp/meta.cmx : bytecomp/instruct.cmx bytecomp/meta.cmi +bytecomp/meta.cmi : bytecomp/instruct.cmi bytecomp/opcodes.cmo : bytecomp/opcodes.cmx : bytecomp/printinstr.cmo : bytecomp/printlambda.cmi parsing/location.cmi \ @@ -598,14 +586,17 @@ bytecomp/printinstr.cmo : bytecomp/printlambda.cmi parsing/location.cmi \ bytecomp/printinstr.cmx : bytecomp/printlambda.cmx parsing/location.cmx \ bytecomp/lambda.cmx bytecomp/instruct.cmx typing/ident.cmx \ bytecomp/printinstr.cmi +bytecomp/printinstr.cmi : bytecomp/instruct.cmi bytecomp/printlambda.cmo : typing/types.cmi typing/primitive.cmi \ parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \ parsing/asttypes.cmi bytecomp/printlambda.cmi bytecomp/printlambda.cmx : typing/types.cmx typing/primitive.cmx \ parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \ parsing/asttypes.cmi bytecomp/printlambda.cmi +bytecomp/printlambda.cmi : bytecomp/lambda.cmi bytecomp/runtimedef.cmo : bytecomp/runtimedef.cmi bytecomp/runtimedef.cmx : bytecomp/runtimedef.cmi +bytecomp/runtimedef.cmi : bytecomp/simplif.cmo : utils/warnings.cmi utils/tbl.cmi typing/stypes.cmi \ utils/misc.cmi parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \ utils/clflags.cmi parsing/asttypes.cmi typing/annot.cmi \ @@ -614,8 +605,11 @@ bytecomp/simplif.cmx : utils/warnings.cmx utils/tbl.cmx typing/stypes.cmx \ utils/misc.cmx parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \ utils/clflags.cmx parsing/asttypes.cmi typing/annot.cmi \ bytecomp/simplif.cmi +bytecomp/simplif.cmi : utils/misc.cmi parsing/location.cmi \ + bytecomp/lambda.cmi typing/ident.cmi bytecomp/switch.cmo : bytecomp/switch.cmi bytecomp/switch.cmx : bytecomp/switch.cmi +bytecomp/switch.cmi : bytecomp/symtable.cmo : utils/tbl.cmi bytecomp/runtimedef.cmi \ typing/predef.cmi utils/misc.cmi bytecomp/meta.cmi parsing/location.cmi \ bytecomp/lambda.cmi typing/ident.cmi bytecomp/dll.cmi utils/config.cmi \ @@ -626,6 +620,8 @@ bytecomp/symtable.cmx : utils/tbl.cmx bytecomp/runtimedef.cmx \ bytecomp/lambda.cmx typing/ident.cmx bytecomp/dll.cmx utils/config.cmx \ bytecomp/cmo_format.cmi utils/clflags.cmx bytecomp/bytesections.cmx \ parsing/asttypes.cmi bytecomp/symtable.cmi +bytecomp/symtable.cmi : utils/misc.cmi typing/ident.cmi \ + bytecomp/cmo_format.cmi bytecomp/translattribute.cmo : utils/warnings.cmi typing/typedtree.cmi \ parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \ parsing/location.cmi bytecomp/lambda.cmi utils/config.cmi \ @@ -634,6 +630,8 @@ bytecomp/translattribute.cmx : utils/warnings.cmx typing/typedtree.cmx \ parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \ parsing/location.cmx bytecomp/lambda.cmx utils/config.cmx \ bytecomp/translattribute.cmi +bytecomp/translattribute.cmi : typing/typedtree.cmi parsing/parsetree.cmi \ + parsing/location.cmi bytecomp/lambda.cmi bytecomp/translclass.cmo : typing/types.cmi bytecomp/typeopt.cmi \ typing/typedtree.cmi bytecomp/translobj.cmi bytecomp/translcore.cmi \ typing/path.cmi bytecomp/matching.cmi parsing/location.cmi \ @@ -644,6 +642,8 @@ bytecomp/translclass.cmx : typing/types.cmx bytecomp/typeopt.cmx \ typing/path.cmx bytecomp/matching.cmx parsing/location.cmx \ bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx utils/clflags.cmx \ typing/btype.cmx parsing/asttypes.cmi bytecomp/translclass.cmi +bytecomp/translclass.cmi : typing/typedtree.cmi parsing/location.cmi \ + bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi bytecomp/translcore.cmo : typing/types.cmi bytecomp/typeopt.cmi \ typing/typedtree.cmi bytecomp/translobj.cmi bytecomp/translattribute.cmi \ typing/primitive.cmi typing/predef.cmi typing/path.cmi \ @@ -658,6 +658,9 @@ bytecomp/translcore.cmx : typing/types.cmx bytecomp/typeopt.cmx \ parsing/longident.cmx parsing/location.cmx bytecomp/lambda.cmx \ typing/ident.cmx typing/env.cmx utils/config.cmx utils/clflags.cmx \ typing/btype.cmx parsing/asttypes.cmi bytecomp/translcore.cmi +bytecomp/translcore.cmi : typing/types.cmi typing/typedtree.cmi \ + typing/primitive.cmi typing/path.cmi parsing/location.cmi \ + bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi bytecomp/translmod.cmo : typing/types.cmi typing/typedtree.cmi \ bytecomp/translobj.cmi bytecomp/translcore.cmi bytecomp/translclass.cmi \ bytecomp/translattribute.cmi typing/printtyp.cmi typing/primitive.cmi \ @@ -672,99 +675,32 @@ bytecomp/translmod.cmx : typing/types.cmx typing/typedtree.cmx \ parsing/longident.cmx parsing/location.cmx bytecomp/lambda.cmx \ typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/clflags.cmx \ parsing/asttypes.cmi bytecomp/translmod.cmi +bytecomp/translmod.cmi : typing/typedtree.cmi typing/primitive.cmi \ + parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi bytecomp/translobj.cmo : typing/primitive.cmi utils/misc.cmi \ - parsing/longident.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \ - utils/config.cmi utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ - bytecomp/translobj.cmi + parsing/longident.cmi parsing/location.cmi bytecomp/lambda.cmi \ + typing/ident.cmi typing/env.cmi utils/config.cmi utils/clflags.cmi \ + typing/btype.cmi parsing/asttypes.cmi bytecomp/translobj.cmi bytecomp/translobj.cmx : typing/primitive.cmx utils/misc.cmx \ - parsing/longident.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \ - utils/config.cmx utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ - bytecomp/translobj.cmi + parsing/longident.cmx parsing/location.cmx bytecomp/lambda.cmx \ + typing/ident.cmx typing/env.cmx utils/config.cmx utils/clflags.cmx \ + typing/btype.cmx parsing/asttypes.cmi bytecomp/translobj.cmi +bytecomp/translobj.cmi : bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi bytecomp/typeopt.cmo : typing/types.cmi typing/typedtree.cmi \ - typing/predef.cmi typing/path.cmi bytecomp/lambda.cmi typing/ident.cmi \ - typing/env.cmi typing/ctype.cmi bytecomp/typeopt.cmi + typing/typedecl.cmi typing/predef.cmi typing/path.cmi bytecomp/lambda.cmi \ + typing/ident.cmi typing/env.cmi typing/ctype.cmi bytecomp/typeopt.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 bytecomp/typeopt.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 middle_end/backend_intf.cmi -asmcomp/branch_relaxation.cmi : asmcomp/linearize.cmi \ - asmcomp/branch_relaxation_intf.cmo -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 : 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/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 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/emit.cmi : asmcomp/linearize.cmi asmcomp/cmm.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 -asmcomp/liveness.cmi : asmcomp/mach.cmi -asmcomp/mach.cmi : asmcomp/reg.cmi bytecomp/lambda.cmi \ - bytecomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo -asmcomp/printclambda.cmi : asmcomp/clambda.cmi -asmcomp/printcmm.cmi : asmcomp/cmm.cmi -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/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 \ - typing/ident.cmi bytecomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo -asmcomp/selection.cmi : asmcomp/mach.cmi asmcomp/cmm.cmi -asmcomp/spill.cmi : asmcomp/mach.cmi -asmcomp/split.cmi : asmcomp/mach.cmi -asmcomp/strmatch.cmi : asmcomp/cmm.cmi -asmcomp/un_anf.cmi : asmcomp/clambda.cmi -asmcomp/x86_ast.cmi : -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 + typing/typedecl.cmx typing/predef.cmx typing/path.cmx bytecomp/lambda.cmx \ + typing/ident.cmx typing/env.cmx typing/ctype.cmx bytecomp/typeopt.cmi +bytecomp/typeopt.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ + bytecomp/lambda.cmi typing/env.cmi asmcomp/CSE.cmo : asmcomp/mach.cmi asmcomp/CSEgen.cmi asmcomp/arch.cmo asmcomp/CSE.cmx : asmcomp/mach.cmx asmcomp/CSEgen.cmx asmcomp/arch.cmx asmcomp/CSEgen.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \ asmcomp/cmm.cmi asmcomp/CSEgen.cmi asmcomp/CSEgen.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \ asmcomp/cmm.cmx asmcomp/CSEgen.cmi +asmcomp/CSEgen.cmi : asmcomp/mach.cmi asmcomp/arch.cmo : utils/clflags.cmi asmcomp/arch.cmx : utils/clflags.cmx asmcomp/asmgen.cmo : asmcomp/un_anf.cmi bytecomp/translmod.cmi \ @@ -775,12 +711,12 @@ asmcomp/asmgen.cmo : asmcomp/un_anf.cmi bytecomp/translmod.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/clambda.cmi asmcomp/CSE.cmo asmcomp/build_export_info.cmi \ - asmcomp/asmgen.cmi + typing/ident.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/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 \ @@ -789,12 +725,14 @@ asmcomp/asmgen.cmx : asmcomp/un_anf.cmx bytecomp/translmod.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/clambda.cmx asmcomp/CSE.cmx asmcomp/build_export_info.cmx \ - asmcomp/asmgen.cmi + typing/ident.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/clambda.cmx asmcomp/CSE.cmx \ + asmcomp/build_export_info.cmx asmcomp/asmgen.cmi +asmcomp/asmgen.cmi : utils/timings.cmi bytecomp/lambda.cmi typing/ident.cmi \ + middle_end/flambda.cmi asmcomp/cmm.cmi middle_end/backend_intf.cmi asmcomp/asmlibrarian.cmo : utils/misc.cmi parsing/location.cmi \ asmcomp/export_info.cmi utils/config.cmi asmcomp/compilenv.cmi \ asmcomp/cmx_format.cmi utils/clflags.cmi asmcomp/clambda.cmi \ @@ -803,6 +741,7 @@ asmcomp/asmlibrarian.cmx : utils/misc.cmx parsing/location.cmx \ 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/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 \ @@ -813,6 +752,7 @@ asmcomp/asmlink.cmx : utils/timings.cmx bytecomp/runtimedef.cmx \ utils/consistbl.cmx utils/config.cmx asmcomp/compilenv.cmx \ asmcomp/cmx_format.cmi asmcomp/cmmgen.cmx utils/clflags.cmx \ utils/ccomp.cmx asmcomp/asmgen.cmx asmcomp/asmlink.cmi +asmcomp/asmlink.cmi : asmcomp/cmx_format.cmi asmcomp/asmpackager.cmo : typing/typemod.cmi bytecomp/translmod.cmi \ utils/timings.cmi utils/misc.cmi middle_end/middle_end.cmi \ parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \ @@ -829,14 +769,19 @@ asmcomp/asmpackager.cmx : typing/typemod.cmx bytecomp/translmod.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/asmpackager.cmi : typing/env.cmi middle_end/backend_intf.cmi 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/branch_relaxation_intf.cmo : asmcomp/linearize.cmi asmcomp/arch.cmo -asmcomp/branch_relaxation_intf.cmx : asmcomp/linearize.cmx asmcomp/arch.cmx +asmcomp/branch_relaxation.cmi : asmcomp/linearize.cmi \ + asmcomp/branch_relaxation_intf.cmo +asmcomp/branch_relaxation_intf.cmo : asmcomp/linearize.cmi asmcomp/cmm.cmi \ + asmcomp/arch.cmo +asmcomp/branch_relaxation_intf.cmx : asmcomp/linearize.cmx asmcomp/cmm.cmx \ + asmcomp/arch.cmx asmcomp/build_export_info.cmo : middle_end/base_types/variable.cmi \ middle_end/base_types/var_within_closure.cmi \ middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \ @@ -857,22 +802,27 @@ asmcomp/build_export_info.cmx : middle_end/base_types/variable.cmx \ middle_end/base_types/closure_id.cmx utils/clflags.cmx \ middle_end/backend_intf.cmi middle_end/allocated_const.cmx \ asmcomp/build_export_info.cmi +asmcomp/build_export_info.cmi : middle_end/flambda.cmi \ + asmcomp/export_info.cmi middle_end/backend_intf.cmi asmcomp/clambda.cmo : bytecomp/lambda.cmi typing/ident.cmi \ - bytecomp/debuginfo.cmi parsing/asttypes.cmi asmcomp/clambda.cmi + middle_end/debuginfo.cmi parsing/asttypes.cmi asmcomp/clambda.cmi asmcomp/clambda.cmx : bytecomp/lambda.cmx typing/ident.cmx \ - bytecomp/debuginfo.cmx parsing/asttypes.cmi asmcomp/clambda.cmi + middle_end/debuginfo.cmx parsing/asttypes.cmi asmcomp/clambda.cmi +asmcomp/clambda.cmi : bytecomp/lambda.cmi typing/ident.cmi \ + middle_end/debuginfo.cmi parsing/asttypes.cmi asmcomp/closure.cmo : utils/warnings.cmi utils/tbl.cmi bytecomp/switch.cmi \ bytecomp/simplif.cmi typing/primitive.cmi utils/misc.cmi \ parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \ - bytecomp/debuginfo.cmi asmcomp/compilenv.cmi utils/clflags.cmi \ - asmcomp/clambda.cmi parsing/asttypes.cmi asmcomp/arch.cmo \ - asmcomp/closure.cmi + middle_end/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \ + utils/clflags.cmi asmcomp/clambda.cmi parsing/asttypes.cmi \ + asmcomp/arch.cmo asmcomp/closure.cmi asmcomp/closure.cmx : utils/warnings.cmx utils/tbl.cmx bytecomp/switch.cmx \ bytecomp/simplif.cmx typing/primitive.cmx utils/misc.cmx \ parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \ - bytecomp/debuginfo.cmx asmcomp/compilenv.cmx utils/clflags.cmx \ - asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/arch.cmx \ - asmcomp/closure.cmi + middle_end/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \ + utils/clflags.cmx asmcomp/clambda.cmx parsing/asttypes.cmi \ + asmcomp/arch.cmx asmcomp/closure.cmi +asmcomp/closure.cmi : bytecomp/lambda.cmi asmcomp/clambda.cmi asmcomp/closure_offsets.cmo : middle_end/base_types/variable.cmi \ middle_end/base_types/var_within_closure.cmi utils/misc.cmi \ middle_end/flambda_utils.cmi middle_end/flambda_iterators.cmi \ @@ -883,30 +833,39 @@ asmcomp/closure_offsets.cmx : middle_end/base_types/variable.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/closure_offsets.cmi : middle_end/base_types/var_within_closure.cmi \ + middle_end/flambda.cmi middle_end/base_types/closure_id.cmi asmcomp/cmm.cmo : bytecomp/lambda.cmi typing/ident.cmi \ - bytecomp/debuginfo.cmi asmcomp/arch.cmo asmcomp/cmm.cmi + middle_end/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 + middle_end/debuginfo.cmx asmcomp/arch.cmx asmcomp/cmm.cmi +asmcomp/cmm.cmi : bytecomp/lambda.cmi typing/ident.cmi \ + middle_end/debuginfo.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 \ + middle_end/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 \ + middle_end/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/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.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/coloring.cmi asmcomp/coloring.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/coloring.cmi +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/comballoc.cmi : asmcomp/mach.cmi 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 \ @@ -923,28 +882,35 @@ asmcomp/compilenv.cmx : utils/warnings.cmx middle_end/base_types/symbol.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/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.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \ - asmcomp/deadcode.cmi + utils/config.cmi asmcomp/deadcode.cmi asmcomp/deadcode.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \ - asmcomp/deadcode.cmi + utils/config.cmx asmcomp/deadcode.cmi +asmcomp/deadcode.cmi : asmcomp/mach.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 \ - asmcomp/linearize.cmi bytecomp/lambda.cmi asmcomp/emitaux.cmi \ - bytecomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \ - asmcomp/cmm.cmi utils/clflags.cmi asmcomp/branch_relaxation.cmi \ - asmcomp/arch.cmo asmcomp/emit.cmi + asmcomp/linearize.cmi asmcomp/emitaux.cmi middle_end/debuginfo.cmi \ + utils/config.cmi asmcomp/compilenv.cmi asmcomp/cmm.cmi utils/clflags.cmi \ + asmcomp/branch_relaxation.cmi asmcomp/arch.cmo asmcomp/emit.cmi asmcomp/emit.cmx : asmcomp/x86_proc.cmx asmcomp/x86_masm.cmx \ asmcomp/x86_gas.cmx asmcomp/x86_dsl.cmx asmcomp/x86_ast.cmi \ asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx asmcomp/mach.cmx \ - asmcomp/linearize.cmx bytecomp/lambda.cmx asmcomp/emitaux.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/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/linearize.cmx asmcomp/emitaux.cmx middle_end/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/emit.cmi : asmcomp/linearize.cmi asmcomp/cmm.cmi +asmcomp/emitaux.cmo : middle_end/debuginfo.cmi utils/config.cmi \ + asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/emitaux.cmi +asmcomp/emitaux.cmx : middle_end/debuginfo.cmx utils/config.cmx \ + asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emitaux.cmi +asmcomp/emitaux.cmi : middle_end/debuginfo.cmi asmcomp/export_info.cmo : middle_end/base_types/variable.cmi \ middle_end/base_types/var_within_closure.cmi \ middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \ @@ -961,6 +927,14 @@ asmcomp/export_info.cmx : middle_end/base_types/variable.cmx \ middle_end/base_types/export_id.cmx \ middle_end/base_types/compilation_unit.cmx \ middle_end/base_types/closure_id.cmx asmcomp/export_info.cmi +asmcomp/export_info.cmi : middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.cmi \ + middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \ + middle_end/simple_value_approx.cmi \ + middle_end/base_types/set_of_closures_id.cmi middle_end/flambda.cmi \ + middle_end/base_types/export_id.cmi \ + middle_end/base_types/compilation_unit.cmi \ + middle_end/base_types/closure_id.cmi asmcomp/export_info_for_pack.cmo : middle_end/base_types/variable.cmi \ middle_end/base_types/var_within_closure.cmi \ middle_end/base_types/symbol.cmi \ @@ -979,6 +953,8 @@ asmcomp/export_info_for_pack.cmx : middle_end/base_types/variable.cmx \ middle_end/base_types/export_id.cmx \ middle_end/base_types/compilation_unit.cmx \ middle_end/base_types/closure_id.cmx asmcomp/export_info_for_pack.cmi +asmcomp/export_info_for_pack.cmi : asmcomp/export_info.cmi \ + middle_end/base_types/compilation_unit.cmi asmcomp/flambda_to_clambda.cmo : middle_end/base_types/variable.cmi \ middle_end/base_types/var_within_closure.cmi \ middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \ @@ -987,7 +963,7 @@ asmcomp/flambda_to_clambda.cmo : middle_end/base_types/variable.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/export_info.cmi middle_end/debuginfo.cmi asmcomp/compilenv.cmi \ asmcomp/closure_offsets.cmi middle_end/base_types/closure_id.cmi \ utils/clflags.cmi asmcomp/clambda.cmi middle_end/allocated_const.cmi \ asmcomp/flambda_to_clambda.cmi @@ -999,10 +975,12 @@ asmcomp/flambda_to_clambda.cmx : middle_end/base_types/variable.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/export_info.cmx middle_end/debuginfo.cmx asmcomp/compilenv.cmx \ asmcomp/closure_offsets.cmx middle_end/base_types/closure_id.cmx \ utils/clflags.cmx asmcomp/clambda.cmx middle_end/allocated_const.cmx \ asmcomp/flambda_to_clambda.cmi +asmcomp/flambda_to_clambda.cmi : middle_end/base_types/symbol.cmi \ + middle_end/flambda.cmi asmcomp/export_info.cmi asmcomp/clambda.cmi asmcomp/import_approx.cmo : middle_end/base_types/variable.cmi \ middle_end/base_types/var_within_closure.cmi \ middle_end/base_types/symbol.cmi middle_end/simple_value_approx.cmi \ @@ -1019,254 +997,162 @@ asmcomp/import_approx.cmx : middle_end/base_types/variable.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/import_approx.cmi : middle_end/base_types/symbol.cmi \ + middle_end/simple_value_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 \ asmcomp/interf.cmi +asmcomp/interf.cmi : asmcomp/mach.cmi asmcomp/linearize.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ - asmcomp/mach.cmi bytecomp/lambda.cmi bytecomp/debuginfo.cmi \ + asmcomp/mach.cmi middle_end/debuginfo.cmi utils/config.cmi \ asmcomp/cmm.cmi asmcomp/linearize.cmi asmcomp/linearize.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ - asmcomp/mach.cmx bytecomp/lambda.cmx bytecomp/debuginfo.cmx \ + asmcomp/mach.cmx middle_end/debuginfo.cmx utils/config.cmx \ asmcomp/cmm.cmx asmcomp/linearize.cmi +asmcomp/linearize.cmi : asmcomp/reg.cmi asmcomp/mach.cmi \ + middle_end/debuginfo.cmi asmcomp/cmm.cmi asmcomp/liveness.cmo : asmcomp/reg.cmi asmcomp/proc.cmi \ - asmcomp/printmach.cmi utils/misc.cmi asmcomp/mach.cmi \ + asmcomp/printmach.cmi utils/misc.cmi asmcomp/mach.cmi utils/config.cmi \ asmcomp/liveness.cmi asmcomp/liveness.cmx : asmcomp/reg.cmx asmcomp/proc.cmx \ - asmcomp/printmach.cmx utils/misc.cmx asmcomp/mach.cmx \ + asmcomp/printmach.cmx utils/misc.cmx asmcomp/mach.cmx utils/config.cmx \ asmcomp/liveness.cmi -asmcomp/mach.cmo : asmcomp/reg.cmi bytecomp/lambda.cmi \ - bytecomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/mach.cmi -asmcomp/mach.cmx : asmcomp/reg.cmx bytecomp/lambda.cmx \ - bytecomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/mach.cmi +asmcomp/liveness.cmi : asmcomp/mach.cmi +asmcomp/mach.cmo : asmcomp/reg.cmi middle_end/debuginfo.cmi asmcomp/cmm.cmi \ + asmcomp/arch.cmo asmcomp/mach.cmi +asmcomp/mach.cmx : asmcomp/reg.cmx middle_end/debuginfo.cmx asmcomp/cmm.cmx \ + asmcomp/arch.cmx asmcomp/mach.cmi +asmcomp/mach.cmi : asmcomp/reg.cmi middle_end/debuginfo.cmi asmcomp/cmm.cmi \ + asmcomp/arch.cmo asmcomp/printclambda.cmo : bytecomp/printlambda.cmi bytecomp/lambda.cmi \ typing/ident.cmi asmcomp/clambda.cmi parsing/asttypes.cmi \ asmcomp/printclambda.cmi asmcomp/printclambda.cmx : bytecomp/printlambda.cmx bytecomp/lambda.cmx \ typing/ident.cmx asmcomp/clambda.cmx parsing/asttypes.cmi \ asmcomp/printclambda.cmi +asmcomp/printclambda.cmi : asmcomp/clambda.cmi asmcomp/printcmm.cmo : bytecomp/lambda.cmi typing/ident.cmi \ - bytecomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/printcmm.cmi + middle_end/debuginfo.cmi asmcomp/cmm.cmi asmcomp/printcmm.cmi asmcomp/printcmm.cmx : bytecomp/lambda.cmx typing/ident.cmx \ - bytecomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/printcmm.cmi -asmcomp/printlinear.cmo : asmcomp/printmach.cmi asmcomp/mach.cmi \ - asmcomp/linearize.cmi bytecomp/lambda.cmi bytecomp/debuginfo.cmi \ + middle_end/debuginfo.cmx asmcomp/cmm.cmx asmcomp/printcmm.cmi +asmcomp/printcmm.cmi : asmcomp/cmm.cmi +asmcomp/printlinear.cmo : asmcomp/printmach.cmi asmcomp/printcmm.cmi \ + asmcomp/mach.cmi asmcomp/linearize.cmi middle_end/debuginfo.cmi \ asmcomp/printlinear.cmi -asmcomp/printlinear.cmx : asmcomp/printmach.cmx asmcomp/mach.cmx \ - asmcomp/linearize.cmx bytecomp/lambda.cmx bytecomp/debuginfo.cmx \ +asmcomp/printlinear.cmx : asmcomp/printmach.cmx asmcomp/printcmm.cmx \ + asmcomp/mach.cmx asmcomp/linearize.cmx middle_end/debuginfo.cmx \ asmcomp/printlinear.cmi +asmcomp/printlinear.cmi : asmcomp/linearize.cmi asmcomp/printmach.cmo : asmcomp/reg.cmi asmcomp/proc.cmi \ - asmcomp/printcmm.cmi asmcomp/mach.cmi bytecomp/lambda.cmi \ - bytecomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \ - asmcomp/printmach.cmi + asmcomp/printcmm.cmi asmcomp/mach.cmi middle_end/debuginfo.cmi \ + utils/config.cmi asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/printmach.cmi asmcomp/printmach.cmx : asmcomp/reg.cmx asmcomp/proc.cmx \ - asmcomp/printcmm.cmx asmcomp/mach.cmx bytecomp/lambda.cmx \ - bytecomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ - asmcomp/printmach.cmi + asmcomp/printcmm.cmx asmcomp/mach.cmx middle_end/debuginfo.cmx \ + utils/config.cmx asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/printmach.cmi +asmcomp/printmach.cmi : asmcomp/reg.cmi asmcomp/mach.cmi asmcomp/proc.cmo : asmcomp/x86_proc.cmi asmcomp/reg.cmi utils/misc.cmi \ asmcomp/mach.cmi utils/config.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \ asmcomp/proc.cmi asmcomp/proc.cmx : asmcomp/x86_proc.cmx asmcomp/reg.cmx utils/misc.cmx \ asmcomp/mach.cmx utils/config.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ asmcomp/proc.cmi +asmcomp/proc.cmi : asmcomp/reg.cmi asmcomp/mach.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/reg.cmi : typing/ident.cmi asmcomp/cmm.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/reload.cmi : asmcomp/mach.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/reloadgen.cmi : asmcomp/reg.cmi asmcomp/mach.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 asmcomp/schedgen.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \ asmcomp/linearize.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ asmcomp/schedgen.cmi +asmcomp/schedgen.cmi : asmcomp/mach.cmi asmcomp/linearize.cmi asmcomp/scheduling.cmo : asmcomp/schedgen.cmi asmcomp/scheduling.cmi asmcomp/scheduling.cmx : asmcomp/schedgen.cmx asmcomp/scheduling.cmi +asmcomp/scheduling.cmi : asmcomp/linearize.cmi asmcomp/selectgen.cmo : utils/tbl.cmi bytecomp/simplif.cmi asmcomp/reg.cmi \ asmcomp/proc.cmi utils/misc.cmi asmcomp/mach.cmi bytecomp/lambda.cmi \ - typing/ident.cmi bytecomp/debuginfo.cmi asmcomp/cmm.cmi utils/clflags.cmi \ - asmcomp/arch.cmo asmcomp/selectgen.cmi + typing/ident.cmi middle_end/debuginfo.cmi utils/config.cmi \ + asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/selectgen.cmi asmcomp/selectgen.cmx : utils/tbl.cmx bytecomp/simplif.cmx asmcomp/reg.cmx \ asmcomp/proc.cmx utils/misc.cmx asmcomp/mach.cmx bytecomp/lambda.cmx \ - typing/ident.cmx bytecomp/debuginfo.cmx asmcomp/cmm.cmx utils/clflags.cmx \ - asmcomp/arch.cmx asmcomp/selectgen.cmi -asmcomp/selection.cmo : asmcomp/selectgen.cmi asmcomp/proc.cmi \ - asmcomp/mach.cmi asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo \ - asmcomp/selection.cmi -asmcomp/selection.cmx : asmcomp/selectgen.cmx asmcomp/proc.cmx \ - asmcomp/mach.cmx asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx \ - asmcomp/selection.cmi + typing/ident.cmx middle_end/debuginfo.cmx utils/config.cmx \ + asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/selectgen.cmi +asmcomp/selectgen.cmi : utils/tbl.cmi asmcomp/reg.cmi asmcomp/mach.cmi \ + typing/ident.cmi middle_end/debuginfo.cmi asmcomp/cmm.cmi \ + asmcomp/arch.cmo +asmcomp/selection.cmo : asmcomp/spacetime_profiling.cmi asmcomp/proc.cmi \ + asmcomp/mach.cmi utils/config.cmi asmcomp/cmm.cmi utils/clflags.cmi \ + asmcomp/arch.cmo asmcomp/selection.cmi +asmcomp/selection.cmx : asmcomp/spacetime_profiling.cmx asmcomp/proc.cmx \ + asmcomp/mach.cmx utils/config.cmx asmcomp/cmm.cmx utils/clflags.cmx \ + asmcomp/arch.cmx asmcomp/selection.cmi +asmcomp/selection.cmi : asmcomp/mach.cmi asmcomp/cmm.cmi +asmcomp/spacetime_profiling.cmo : utils/tbl.cmi asmcomp/selectgen.cmi \ + asmcomp/proc.cmi utils/misc.cmi asmcomp/mach.cmi bytecomp/lambda.cmi \ + typing/ident.cmi middle_end/debuginfo.cmi utils/config.cmi \ + asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/spacetime_profiling.cmi +asmcomp/spacetime_profiling.cmx : utils/tbl.cmx asmcomp/selectgen.cmx \ + asmcomp/proc.cmx utils/misc.cmx asmcomp/mach.cmx bytecomp/lambda.cmx \ + typing/ident.cmx middle_end/debuginfo.cmx utils/config.cmx \ + asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/spacetime_profiling.cmi +asmcomp/spacetime_profiling.cmi : asmcomp/selectgen.cmi asmcomp/spill.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ asmcomp/mach.cmi asmcomp/spill.cmi asmcomp/spill.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ asmcomp/mach.cmx asmcomp/spill.cmi +asmcomp/spill.cmi : asmcomp/mach.cmi asmcomp/split.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ asmcomp/split.cmi asmcomp/split.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ asmcomp/split.cmi +asmcomp/split.cmi : asmcomp/mach.cmi asmcomp/strmatch.cmo : 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/strmatch.cmi : asmcomp/cmm.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/clflags.cmi \ + typing/ident.cmi middle_end/debuginfo.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/clflags.cmx \ + typing/ident.cmx middle_end/debuginfo.cmx utils/clflags.cmx \ asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/un_anf.cmi +asmcomp/un_anf.cmi : asmcomp/clambda.cmi +asmcomp/x86_ast.cmi : asmcomp/x86_dsl.cmo : asmcomp/x86_proc.cmi asmcomp/x86_ast.cmi \ asmcomp/x86_dsl.cmi asmcomp/x86_dsl.cmx : asmcomp/x86_proc.cmx asmcomp/x86_ast.cmi \ asmcomp/x86_dsl.cmi +asmcomp/x86_dsl.cmi : asmcomp/x86_ast.cmi asmcomp/x86_gas.cmo : asmcomp/x86_proc.cmi asmcomp/x86_ast.cmi \ utils/misc.cmi asmcomp/x86_gas.cmi asmcomp/x86_gas.cmx : asmcomp/x86_proc.cmx asmcomp/x86_ast.cmi \ utils/misc.cmx asmcomp/x86_gas.cmi +asmcomp/x86_gas.cmi : asmcomp/x86_ast.cmi asmcomp/x86_masm.cmo : asmcomp/x86_proc.cmi asmcomp/x86_ast.cmi \ asmcomp/x86_masm.cmi asmcomp/x86_masm.cmx : asmcomp/x86_proc.cmx asmcomp/x86_ast.cmi \ asmcomp/x86_masm.cmi +asmcomp/x86_masm.cmi : asmcomp/x86_ast.cmi asmcomp/x86_proc.cmo : asmcomp/x86_ast.cmi utils/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_specialised_args.cmi : middle_end/base_types/variable.cmi \ - middle_end/projection.cmi middle_end/inlining_cost.cmi \ - middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi -middle_end/backend_intf.cmi : middle_end/base_types/symbol.cmi \ - middle_end/simple_value_approx.cmi typing/ident.cmi \ - middle_end/base_types/closure_id.cmi -middle_end/closure_conversion.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/extract_projections.cmi : middle_end/base_types/variable.cmi \ - middle_end/projection.cmi middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda.cmi -middle_end/find_recursive_functions.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/tag.cmi middle_end/base_types/symbol.cmi \ - middle_end/base_types/static_exception.cmi \ - middle_end/base_types/set_of_closures_origin.cmi \ - middle_end/base_types/set_of_closures_id.cmi middle_end/projection.cmi \ - 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/projection.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/base_types/variable.cmi \ - middle_end/inline_and_simplify_aux.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_origin.cmi \ - middle_end/projection.cmi middle_end/base_types/mutable_variable.cmi \ - middle_end/inlining_stats_types.cmi middle_end/inlining_cost.cmi \ - middle_end/freshening.cmi middle_end/flambda.cmi bytecomp/debuginfo.cmi \ - middle_end/base_types/closure_id.cmi middle_end/backend_intf.cmi -middle_end/inlining_cost.cmi : middle_end/projection.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/pass_wrapper.cmi : -middle_end/projection.cmi : middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi utils/identifiable.cmi \ - middle_end/base_types/closure_id.cmi -middle_end/ref_to_variables.cmi : middle_end/flambda.cmi -middle_end/remove_free_vars_equal_to_args.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/inlining_cost.cmi middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda.cmi -middle_end/unbox_free_vars_of_closures.cmi : middle_end/inlining_cost.cmi \ - middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi -middle_end/unbox_specialised_args.cmi : middle_end/base_types/variable.cmi \ - middle_end/inlining_cost.cmi middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda.cmi +asmcomp/x86_proc.cmi : asmcomp/x86_ast.cmi middle_end/alias_analysis.cmo : middle_end/base_types/variable.cmi \ middle_end/base_types/var_within_closure.cmi \ middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \ @@ -1279,24 +1165,33 @@ middle_end/alias_analysis.cmx : middle_end/base_types/variable.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/alias_analysis.cmi : middle_end/base_types/variable.cmi \ + middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \ + bytecomp/lambda.cmi middle_end/flambda.cmi parsing/asttypes.cmi \ + middle_end/allocated_const.cmi middle_end/allocated_const.cmo : middle_end/allocated_const.cmi middle_end/allocated_const.cmx : middle_end/allocated_const.cmi +middle_end/allocated_const.cmi : middle_end/augment_specialised_args.cmo : middle_end/base_types/variable.cmi \ - middle_end/simple_value_approx.cmi middle_end/projection.cmi \ - middle_end/pass_wrapper.cmi utils/misc.cmi middle_end/inlining_cost.cmi \ - middle_end/inline_and_simplify_aux.cmi utils/identifiable.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/augment_specialised_args.cmi + middle_end/projection.cmi middle_end/pass_wrapper.cmi utils/misc.cmi \ + middle_end/inlining_cost.cmi middle_end/inline_and_simplify_aux.cmi \ + utils/identifiable.cmi middle_end/flambda_utils.cmi \ + middle_end/flambda.cmi middle_end/debuginfo.cmi \ + middle_end/base_types/closure_id.cmi utils/clflags.cmi \ + middle_end/backend_intf.cmi middle_end/augment_specialised_args.cmi middle_end/augment_specialised_args.cmx : middle_end/base_types/variable.cmx \ - middle_end/simple_value_approx.cmx middle_end/projection.cmx \ - middle_end/pass_wrapper.cmx utils/misc.cmx middle_end/inlining_cost.cmx \ - middle_end/inline_and_simplify_aux.cmx utils/identifiable.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/augment_specialised_args.cmi + middle_end/projection.cmx middle_end/pass_wrapper.cmx utils/misc.cmx \ + middle_end/inlining_cost.cmx middle_end/inline_and_simplify_aux.cmx \ + utils/identifiable.cmx middle_end/flambda_utils.cmx \ + middle_end/flambda.cmx middle_end/debuginfo.cmx \ + middle_end/base_types/closure_id.cmx utils/clflags.cmx \ + middle_end/backend_intf.cmi middle_end/augment_specialised_args.cmi +middle_end/augment_specialised_args.cmi : middle_end/base_types/variable.cmi \ + middle_end/projection.cmi middle_end/inlining_cost.cmi \ + middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi +middle_end/backend_intf.cmi : middle_end/base_types/symbol.cmi \ + middle_end/simple_value_approx.cmi typing/ident.cmi \ + middle_end/base_types/closure_id.cmi middle_end/closure_conversion.cmo : middle_end/base_types/variable.cmi \ middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \ middle_end/base_types/static_exception.cmi bytecomp/simplif.cmi \ @@ -1305,12 +1200,11 @@ middle_end/closure_conversion.cmo : middle_end/base_types/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/flambda.cmi middle_end/debuginfo.cmi utils/config.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/backend_intf.cmi middle_end/closure_conversion.cmi middle_end/closure_conversion.cmx : middle_end/base_types/variable.cmx \ middle_end/base_types/tag.cmx middle_end/base_types/symbol.cmx \ middle_end/base_types/static_exception.cmx bytecomp/simplif.cmx \ @@ -1319,30 +1213,40 @@ middle_end/closure_conversion.cmx : middle_end/base_types/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/flambda.cmx middle_end/debuginfo.cmx utils/config.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/backend_intf.cmi middle_end/closure_conversion.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.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 \ + utils/misc.cmi parsing/location.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 \ + utils/misc.cmx parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \ middle_end/closure_conversion_aux.cmi +middle_end/closure_conversion_aux.cmi : middle_end/base_types/variable.cmi \ + middle_end/base_types/symbol.cmi \ + middle_end/base_types/static_exception.cmi \ + middle_end/base_types/mutable_variable.cmi parsing/location.cmi \ + bytecomp/lambda.cmi typing/ident.cmi +middle_end/debuginfo.cmo : parsing/location.cmi middle_end/debuginfo.cmi +middle_end/debuginfo.cmx : parsing/location.cmx middle_end/debuginfo.cmi +middle_end/debuginfo.cmi : parsing/location.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/effect_analysis.cmi : middle_end/flambda.cmi middle_end/extract_projections.cmo : middle_end/base_types/variable.cmi \ middle_end/base_types/var_within_closure.cmi \ middle_end/simple_value_approx.cmi middle_end/projection.cmi \ @@ -1355,12 +1259,17 @@ middle_end/extract_projections.cmx : middle_end/base_types/variable.cmx \ middle_end/inline_and_simplify_aux.cmx middle_end/freshening.cmx \ middle_end/flambda_iterators.cmx middle_end/flambda.cmx \ middle_end/base_types/closure_id.cmx middle_end/extract_projections.cmi +middle_end/extract_projections.cmi : middle_end/base_types/variable.cmi \ + middle_end/projection.cmi middle_end/inline_and_simplify_aux.cmi \ + middle_end/flambda.cmi middle_end/find_recursive_functions.cmo : middle_end/base_types/variable.cmi \ 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/find_recursive_functions.cmi : middle_end/base_types/variable.cmi \ + middle_end/flambda.cmi middle_end/backend_intf.cmi middle_end/flambda.cmo : middle_end/base_types/variable.cmi \ middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \ middle_end/base_types/static_exception.cmi \ @@ -1368,7 +1277,7 @@ middle_end/flambda.cmo : middle_end/base_types/variable.cmi \ middle_end/base_types/set_of_closures_id.cmi middle_end/projection.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 \ + bytecomp/lambda.cmi utils/identifiable.cmi middle_end/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 \ @@ -1380,11 +1289,20 @@ middle_end/flambda.cmx : middle_end/base_types/variable.cmx \ middle_end/base_types/set_of_closures_id.cmx middle_end/projection.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 \ + bytecomp/lambda.cmx utils/identifiable.cmx middle_end/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.cmi : middle_end/base_types/variable.cmi \ + middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \ + middle_end/base_types/static_exception.cmi \ + middle_end/base_types/set_of_closures_origin.cmi \ + middle_end/base_types/set_of_closures_id.cmi middle_end/projection.cmi \ + utils/numbers.cmi middle_end/base_types/mutable_variable.cmi \ + bytecomp/lambda.cmi utils/identifiable.cmi middle_end/debuginfo.cmi \ + middle_end/base_types/closure_id.cmi parsing/asttypes.cmi \ + middle_end/allocated_const.cmi middle_end/flambda_invariants.cmo : middle_end/base_types/variable.cmi \ middle_end/base_types/var_within_closure.cmi \ middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \ @@ -1394,7 +1312,7 @@ middle_end/flambda_invariants.cmo : middle_end/base_types/variable.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/flambda.cmi middle_end/debuginfo.cmi \ middle_end/base_types/compilation_unit.cmi \ middle_end/base_types/closure_id.cmi parsing/asttypes.cmi \ middle_end/allocated_const.cmi middle_end/flambda_invariants.cmi @@ -1407,14 +1325,17 @@ middle_end/flambda_invariants.cmx : middle_end/base_types/variable.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/flambda.cmx middle_end/debuginfo.cmx \ middle_end/base_types/compilation_unit.cmx \ middle_end/base_types/closure_id.cmx parsing/asttypes.cmi \ middle_end/allocated_const.cmx middle_end/flambda_invariants.cmi +middle_end/flambda_invariants.cmi : middle_end/flambda.cmi middle_end/flambda_iterators.cmo : middle_end/base_types/variable.cmi \ utils/misc.cmi middle_end/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_iterators.cmi : middle_end/base_types/variable.cmi \ + middle_end/base_types/symbol.cmi middle_end/flambda.cmi middle_end/flambda_utils.cmo : middle_end/base_types/variable.cmi \ middle_end/base_types/var_within_closure.cmi \ middle_end/base_types/symbol.cmi bytecomp/switch.cmi \ @@ -1422,7 +1343,7 @@ middle_end/flambda_utils.cmo : middle_end/base_types/variable.cmi \ middle_end/base_types/set_of_closures_id.cmi middle_end/projection.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/flambda.cmi middle_end/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 @@ -1433,10 +1354,17 @@ middle_end/flambda_utils.cmx : middle_end/base_types/variable.cmx \ middle_end/base_types/set_of_closures_id.cmx middle_end/projection.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/flambda.cmx middle_end/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/flambda_utils.cmi : middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.cmi \ + middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \ + bytecomp/switch.cmi middle_end/base_types/static_exception.cmi \ + middle_end/base_types/set_of_closures_id.cmi middle_end/projection.cmi \ + middle_end/flambda.cmi middle_end/base_types/closure_id.cmi \ + middle_end/backend_intf.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 \ @@ -1453,6 +1381,12 @@ middle_end/freshening.cmx : middle_end/base_types/variable.cmx \ utils/identifiable.cmx middle_end/flambda_utils.cmx \ middle_end/flambda_iterators.cmx middle_end/flambda.cmx \ middle_end/base_types/closure_id.cmx middle_end/freshening.cmi +middle_end/freshening.cmi : middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.cmi \ + middle_end/base_types/symbol.cmi \ + middle_end/base_types/static_exception.cmi \ + middle_end/base_types/mutable_variable.cmi middle_end/flambda.cmi \ + middle_end/base_types/closure_id.cmi middle_end/inconstant_idents.cmo : middle_end/base_types/variable.cmi \ middle_end/base_types/symbol.cmi \ middle_end/base_types/set_of_closures_id.cmi utils/numbers.cmi \ @@ -1469,12 +1403,16 @@ middle_end/inconstant_idents.cmx : middle_end/base_types/variable.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/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.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/initialize_symbol_to_let_symbol.cmi : middle_end/flambda.cmi middle_end/inline_and_simplify.cmo : utils/warnings.cmi \ middle_end/base_types/variable.cmi \ middle_end/base_types/var_within_closure.cmi \ @@ -1492,7 +1430,7 @@ middle_end/inline_and_simplify.cmo : utils/warnings.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 \ + middle_end/debuginfo.cmi middle_end/base_types/closure_id.cmi \ utils/clflags.cmi middle_end/backend_intf.cmi \ middle_end/allocated_const.cmi middle_end/inline_and_simplify.cmi middle_end/inline_and_simplify.cmx : utils/warnings.cmx \ @@ -1512,19 +1450,21 @@ middle_end/inline_and_simplify.cmx : utils/warnings.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 \ + middle_end/debuginfo.cmx middle_end/base_types/closure_id.cmx \ utils/clflags.cmx middle_end/backend_intf.cmi \ middle_end/allocated_const.cmx middle_end/inline_and_simplify.cmi +middle_end/inline_and_simplify.cmi : middle_end/base_types/variable.cmi \ + middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi \ + middle_end/backend_intf.cmi middle_end/inline_and_simplify_aux.cmo : middle_end/base_types/variable.cmi \ middle_end/base_types/var_within_closure.cmi \ middle_end/base_types/symbol.cmi \ middle_end/base_types/static_exception.cmi \ middle_end/simple_value_approx.cmi \ middle_end/base_types/set_of_closures_origin.cmi \ - middle_end/projection.cmi 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/flambda.cmi \ + middle_end/projection.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/flambda.cmi middle_end/debuginfo.cmi \ middle_end/base_types/compilation_unit.cmi \ middle_end/base_types/closure_id.cmi utils/clflags.cmi \ middle_end/backend_intf.cmi middle_end/inline_and_simplify_aux.cmi @@ -1534,13 +1474,21 @@ middle_end/inline_and_simplify_aux.cmx : middle_end/base_types/variable.cmx \ middle_end/base_types/static_exception.cmx \ middle_end/simple_value_approx.cmx \ middle_end/base_types/set_of_closures_origin.cmx \ - middle_end/projection.cmx 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/flambda.cmx \ + middle_end/projection.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/flambda.cmx middle_end/debuginfo.cmx \ middle_end/base_types/compilation_unit.cmx \ middle_end/base_types/closure_id.cmx utils/clflags.cmx \ middle_end/backend_intf.cmi middle_end/inline_and_simplify_aux.cmi +middle_end/inline_and_simplify_aux.cmi : middle_end/base_types/variable.cmi \ + middle_end/base_types/symbol.cmi \ + middle_end/base_types/static_exception.cmi \ + middle_end/simple_value_approx.cmi \ + middle_end/base_types/set_of_closures_origin.cmi \ + middle_end/projection.cmi middle_end/base_types/mutable_variable.cmi \ + middle_end/inlining_stats_types.cmi middle_end/inlining_cost.cmi \ + middle_end/freshening.cmi middle_end/flambda.cmi middle_end/debuginfo.cmi \ + middle_end/base_types/closure_id.cmi middle_end/backend_intf.cmi middle_end/inlining_cost.cmo : middle_end/base_types/variable.cmi \ middle_end/projection.cmi typing/primitive.cmi utils/misc.cmi \ bytecomp/lambda.cmi middle_end/flambda_iterators.cmi \ @@ -1549,6 +1497,8 @@ middle_end/inlining_cost.cmx : middle_end/base_types/variable.cmx \ middle_end/projection.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_cost.cmi : middle_end/projection.cmi \ + middle_end/flambda.cmi middle_end/inlining_decision.cmo : middle_end/base_types/variable.cmi \ middle_end/base_types/var_within_closure.cmi \ middle_end/simple_value_approx.cmi utils/misc.cmi bytecomp/lambda.cmi \ @@ -1567,32 +1517,53 @@ middle_end/inlining_decision.cmx : middle_end/base_types/variable.cmx \ middle_end/find_recursive_functions.cmx \ middle_end/base_types/closure_id.cmx utils/clflags.cmx \ middle_end/inlining_decision.cmi +middle_end/inlining_decision.cmi : middle_end/base_types/variable.cmi \ + middle_end/simple_value_approx.cmi bytecomp/lambda.cmi \ + middle_end/inlining_decision_intf.cmi \ + middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi \ + middle_end/debuginfo.cmi middle_end/base_types/closure_id.cmi +middle_end/inlining_decision_intf.cmi : middle_end/base_types/variable.cmi \ + middle_end/simple_value_approx.cmi middle_end/inline_and_simplify_aux.cmi \ + middle_end/flambda.cmi middle_end/debuginfo.cmi \ + middle_end/base_types/closure_id.cmi middle_end/inlining_stats.cmo : utils/misc.cmi \ - middle_end/inlining_stats_types.cmi bytecomp/debuginfo.cmi \ + middle_end/inlining_stats_types.cmi middle_end/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/inlining_stats_types.cmx middle_end/debuginfo.cmx \ middle_end/base_types/closure_id.cmx utils/clflags.cmx \ middle_end/inlining_stats.cmi +middle_end/inlining_stats.cmi : middle_end/inlining_stats_types.cmi \ + middle_end/debuginfo.cmi middle_end/base_types/closure_id.cmi middle_end/inlining_stats_types.cmo : middle_end/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_stats_types.cmi : middle_end/inlining_cost.cmi middle_end/inlining_transforms.cmo : middle_end/base_types/variable.cmi \ middle_end/base_types/var_within_closure.cmi \ middle_end/simple_value_approx.cmi 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/freshening.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 \ + 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/freshening.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 \ + middle_end/inlining_transforms.cmi +middle_end/inlining_transforms.cmi : middle_end/base_types/variable.cmi \ + middle_end/simple_value_approx.cmi bytecomp/lambda.cmi \ + middle_end/inlining_decision_intf.cmi \ + middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi \ + middle_end/debuginfo.cmi middle_end/base_types/closure_id.cmi middle_end/invariant_params.cmo : middle_end/base_types/variable.cmi \ middle_end/base_types/symbol.cmi middle_end/flambda_utils.cmi \ middle_end/flambda_iterators.cmi middle_end/flambda.cmi \ @@ -1603,16 +1574,18 @@ middle_end/invariant_params.cmx : middle_end/base_types/variable.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/invariant_params.cmi : middle_end/base_types/variable.cmi \ + middle_end/flambda.cmi middle_end/backend_intf.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 + utils/strongly_connected_components.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 + utils/strongly_connected_components.cmx middle_end/flambda_iterators.cmx \ + middle_end/flambda.cmx middle_end/base_types/compilation_unit.cmx \ + middle_end/lift_code.cmi +middle_end/lift_code.cmi : middle_end/base_types/variable.cmi \ + middle_end/flambda.cmi middle_end/lift_constants.cmo : middle_end/base_types/variable.cmi \ middle_end/base_types/var_within_closure.cmi \ middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \ @@ -1635,16 +1608,20 @@ middle_end/lift_constants.cmx : middle_end/base_types/variable.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_constants.cmi : middle_end/flambda.cmi \ + middle_end/backend_intf.cmi middle_end/lift_let_to_initialize_symbol.cmo : \ middle_end/base_types/variable.cmi middle_end/base_types/tag.cmi \ middle_end/base_types/symbol.cmi middle_end/flambda_utils.cmi \ - middle_end/flambda.cmi bytecomp/debuginfo.cmi parsing/asttypes.cmi \ + middle_end/flambda.cmi middle_end/debuginfo.cmi parsing/asttypes.cmi \ middle_end/lift_let_to_initialize_symbol.cmi middle_end/lift_let_to_initialize_symbol.cmx : \ middle_end/base_types/variable.cmx middle_end/base_types/tag.cmx \ middle_end/base_types/symbol.cmx middle_end/flambda_utils.cmx \ - middle_end/flambda.cmx bytecomp/debuginfo.cmx parsing/asttypes.cmi \ + middle_end/flambda.cmx middle_end/debuginfo.cmx parsing/asttypes.cmi \ middle_end/lift_let_to_initialize_symbol.cmi +middle_end/lift_let_to_initialize_symbol.cmi : middle_end/flambda.cmi \ + middle_end/backend_intf.cmi middle_end/middle_end.cmo : utils/warnings.cmi \ middle_end/base_types/variable.cmi utils/timings.cmi \ middle_end/base_types/symbol.cmi middle_end/share_constants.cmi \ @@ -1656,7 +1633,7 @@ middle_end/middle_end.cmo : utils/warnings.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/flambda.cmi middle_end/debuginfo.cmi \ middle_end/base_types/closure_id.cmi middle_end/closure_conversion.cmi \ utils/clflags.cmi middle_end/backend_intf.cmi middle_end/middle_end.cmi middle_end/middle_end.cmx : utils/warnings.cmx \ @@ -1670,25 +1647,34 @@ middle_end/middle_end.cmx : utils/warnings.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/flambda.cmx middle_end/debuginfo.cmx \ middle_end/base_types/closure_id.cmx middle_end/closure_conversion.cmx \ utils/clflags.cmx middle_end/backend_intf.cmi middle_end/middle_end.cmi +middle_end/middle_end.cmi : utils/timings.cmi bytecomp/lambda.cmi \ + typing/ident.cmi middle_end/flambda.cmi middle_end/backend_intf.cmi middle_end/pass_wrapper.cmo : utils/clflags.cmi middle_end/pass_wrapper.cmi middle_end/pass_wrapper.cmx : utils/clflags.cmx middle_end/pass_wrapper.cmi +middle_end/pass_wrapper.cmi : middle_end/projection.cmo : middle_end/base_types/variable.cmi \ middle_end/base_types/var_within_closure.cmi utils/identifiable.cmi \ middle_end/base_types/closure_id.cmi middle_end/projection.cmi middle_end/projection.cmx : middle_end/base_types/variable.cmx \ middle_end/base_types/var_within_closure.cmx utils/identifiable.cmx \ middle_end/base_types/closure_id.cmx middle_end/projection.cmi +middle_end/projection.cmi : middle_end/base_types/variable.cmi \ + middle_end/base_types/var_within_closure.cmi utils/identifiable.cmi \ + middle_end/base_types/closure_id.cmi middle_end/ref_to_variables.cmo : middle_end/base_types/variable.cmi \ middle_end/base_types/mutable_variable.cmi utils/misc.cmi \ - middle_end/flambda_iterators.cmi middle_end/flambda.cmi \ - parsing/asttypes.cmi middle_end/ref_to_variables.cmi + bytecomp/lambda.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 + bytecomp/lambda.cmx middle_end/flambda_iterators.cmx \ + middle_end/flambda.cmx parsing/asttypes.cmi \ + middle_end/ref_to_variables.cmi +middle_end/ref_to_variables.cmi : middle_end/flambda.cmi middle_end/remove_free_vars_equal_to_args.cmo : \ middle_end/base_types/variable.cmi middle_end/pass_wrapper.cmi \ middle_end/flambda_utils.cmi middle_end/flambda.cmi \ @@ -1697,6 +1683,7 @@ middle_end/remove_free_vars_equal_to_args.cmx : \ middle_end/base_types/variable.cmx middle_end/pass_wrapper.cmx \ middle_end/flambda_utils.cmx middle_end/flambda.cmx \ middle_end/remove_free_vars_equal_to_args.cmi +middle_end/remove_free_vars_equal_to_args.cmi : middle_end/flambda.cmi middle_end/remove_unused_arguments.cmo : middle_end/base_types/variable.cmi \ middle_end/projection.cmi middle_end/invariant_params.cmi \ middle_end/flambda_utils.cmi middle_end/flambda_iterators.cmi \ @@ -1711,6 +1698,8 @@ middle_end/remove_unused_arguments.cmx : middle_end/base_types/variable.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_arguments.cmi : middle_end/flambda.cmi \ + middle_end/backend_intf.cmi middle_end/remove_unused_closure_vars.cmo : \ middle_end/base_types/variable.cmi \ middle_end/base_types/var_within_closure.cmi middle_end/flambda_utils.cmi \ @@ -1723,6 +1712,7 @@ middle_end/remove_unused_closure_vars.cmx : \ middle_end/flambda_iterators.cmx middle_end/flambda.cmx \ middle_end/base_types/closure_id.cmx \ middle_end/remove_unused_closure_vars.cmi +middle_end/remove_unused_closure_vars.cmi : middle_end/flambda.cmi middle_end/remove_unused_program_constructs.cmo : \ middle_end/base_types/symbol.cmi utils/misc.cmi middle_end/flambda.cmi \ middle_end/effect_analysis.cmi \ @@ -1731,32 +1721,40 @@ 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/remove_unused_program_constructs.cmi : middle_end/flambda.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/semantics_of_primitives.cmi : bytecomp/lambda.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/share_constants.cmi : middle_end/flambda.cmi middle_end/simple_value_approx.cmo : middle_end/base_types/variable.cmi \ middle_end/base_types/var_within_closure.cmi \ middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \ - 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 + utils/misc.cmi bytecomp/lambda.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 + utils/misc.cmx bytecomp/lambda.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/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 \ + bytecomp/lambda.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.cmo : middle_end/simplify_common.cmi \ middle_end/simplify_boxed_integer_ops_intf.cmi \ middle_end/simple_value_approx.cmi bytecomp/lambda.cmi \ @@ -1765,24 +1763,37 @@ 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_boxed_integer_ops.cmi : \ + middle_end/simplify_boxed_integer_ops_intf.cmi +middle_end/simplify_boxed_integer_ops_intf.cmi : \ + middle_end/simple_value_approx.cmi bytecomp/lambda.cmi \ + middle_end/inlining_cost.cmi middle_end/flambda.cmi middle_end/simplify_common.cmo : middle_end/simple_value_approx.cmi \ bytecomp/lambda.cmi middle_end/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_common.cmi : middle_end/simple_value_approx.cmi \ + bytecomp/lambda.cmi middle_end/inlining_cost.cmi middle_end/flambda.cmi middle_end/simplify_primitives.cmo : middle_end/base_types/tag.cmi \ middle_end/base_types/symbol.cmi middle_end/simplify_common.cmi \ middle_end/simplify_boxed_integer_ops.cmi \ - middle_end/simple_value_approx.cmi 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/simple_value_approx.cmi middle_end/semantics_of_primitives.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/simple_value_approx.cmx middle_end/semantics_of_primitives.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/simplify_primitives.cmi : middle_end/base_types/variable.cmi \ + middle_end/simple_value_approx.cmi bytecomp/lambda.cmi \ + middle_end/inlining_cost.cmi middle_end/flambda.cmi \ + middle_end/debuginfo.cmi middle_end/unbox_closures.cmo : middle_end/base_types/variable.cmi \ middle_end/inlining_cost.cmi middle_end/inline_and_simplify_aux.cmi \ middle_end/flambda_utils.cmi middle_end/flambda_iterators.cmi \ @@ -1795,6 +1806,9 @@ middle_end/unbox_closures.cmx : middle_end/base_types/variable.cmx \ middle_end/flambda.cmx middle_end/base_types/closure_id.cmx \ utils/clflags.cmx middle_end/augment_specialised_args.cmx \ middle_end/unbox_closures.cmi +middle_end/unbox_closures.cmi : middle_end/base_types/variable.cmi \ + middle_end/inlining_cost.cmi middle_end/inline_and_simplify_aux.cmi \ + middle_end/flambda.cmi middle_end/unbox_free_vars_of_closures.cmo : \ middle_end/base_types/variable.cmi middle_end/projection.cmi \ middle_end/pass_wrapper.cmi utils/misc.cmi middle_end/inlining_cost.cmi \ @@ -1807,6 +1821,8 @@ middle_end/unbox_free_vars_of_closures.cmx : \ middle_end/flambda_utils.cmx middle_end/flambda_iterators.cmx \ middle_end/flambda.cmx middle_end/extract_projections.cmx \ utils/clflags.cmx middle_end/unbox_free_vars_of_closures.cmi +middle_end/unbox_free_vars_of_closures.cmi : middle_end/inlining_cost.cmi \ + middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi middle_end/unbox_specialised_args.cmo : middle_end/base_types/variable.cmi \ middle_end/projection.cmi middle_end/invariant_params.cmi \ middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi \ @@ -1819,51 +1835,35 @@ middle_end/unbox_specialised_args.cmx : middle_end/base_types/variable.cmx \ middle_end/extract_projections.cmx utils/clflags.cmx \ middle_end/augment_specialised_args.cmx \ middle_end/unbox_specialised_args.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/set_of_closures_origin.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/unbox_specialised_args.cmi : middle_end/base_types/variable.cmi \ + middle_end/inlining_cost.cmi middle_end/inline_and_simplify_aux.cmi \ + middle_end/flambda.cmi middle_end/base_types/closure_element.cmo : \ middle_end/base_types/variable.cmi \ middle_end/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_element.cmi : \ + middle_end/base_types/variable.cmi utils/identifiable.cmi \ + middle_end/base_types/compilation_unit.cmi middle_end/base_types/closure_id.cmo : \ middle_end/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/closure_id.cmi : \ + middle_end/base_types/closure_element.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/compilation_unit.cmi : \ + middle_end/base_types/linkage_name.cmi utils/identifiable.cmi \ + typing/ident.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 \ @@ -1872,20 +1872,26 @@ 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/export_id.cmi : utils/identifiable.cmi \ + middle_end/base_types/compilation_unit.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/id_types.cmi : utils/identifiable.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/linkage_name.cmi : utils/identifiable.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/mutable_variable.cmi : utils/identifiable.cmi \ + typing/ident.cmi middle_end/base_types/compilation_unit.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 \ @@ -1894,16 +1900,22 @@ 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/set_of_closures_id.cmi : utils/identifiable.cmi \ + middle_end/base_types/compilation_unit.cmi middle_end/base_types/set_of_closures_origin.cmo : \ middle_end/base_types/set_of_closures_id.cmi \ middle_end/base_types/set_of_closures_origin.cmi middle_end/base_types/set_of_closures_origin.cmx : \ middle_end/base_types/set_of_closures_id.cmx \ middle_end/base_types/set_of_closures_origin.cmi +middle_end/base_types/set_of_closures_origin.cmi : \ + middle_end/base_types/set_of_closures_id.cmi utils/identifiable.cmi \ + middle_end/base_types/compilation_unit.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/static_exception.cmi : utils/identifiable.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 \ @@ -1912,54 +1924,54 @@ 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/symbol.cmi : middle_end/base_types/linkage_name.cmi \ + utils/identifiable.cmi middle_end/base_types/compilation_unit.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/tag.cmi : utils/identifiable.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/var_within_closure.cmi : \ + middle_end/base_types/closure_element.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.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 +middle_end/base_types/variable.cmi : utils/identifiable.cmi typing/ident.cmi \ + middle_end/base_types/compilation_unit.cmi +driver/compdynlink.cmi : driver/compenv.cmo : utils/warnings.cmi utils/misc.cmi parsing/location.cmi \ - utils/config.cmi utils/clflags.cmi driver/compenv.cmi + utils/config.cmi utils/clflags.cmi utils/ccomp.cmi driver/compenv.cmi driver/compenv.cmx : utils/warnings.cmx utils/misc.cmx parsing/location.cmx \ - utils/config.cmx utils/clflags.cmx driver/compenv.cmi + utils/config.cmx utils/clflags.cmx utils/ccomp.cmx driver/compenv.cmi +driver/compenv.cmi : driver/compile.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 \ bytecomp/printinstr.cmi parsing/printast.cmi parsing/pprintast.cmi \ - driver/pparse.cmi utils/misc.cmi parsing/location.cmi \ + driver/pparse.cmi utils/misc.cmi bytecomp/lambda.cmi \ typing/includemod.cmi typing/env.cmi bytecomp/emitcode.cmi \ - driver/compmisc.cmi driver/compenv.cmi utils/clflags.cmi utils/ccomp.cmi \ + driver/compmisc.cmi driver/compenv.cmi utils/clflags.cmi \ bytecomp/bytegen.cmi parsing/builtin_attributes.cmi driver/compile.cmi driver/compile.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 \ bytecomp/printinstr.cmx parsing/printast.cmx parsing/pprintast.cmx \ - driver/pparse.cmx utils/misc.cmx parsing/location.cmx \ + driver/pparse.cmx utils/misc.cmx bytecomp/lambda.cmx \ typing/includemod.cmx typing/env.cmx bytecomp/emitcode.cmx \ - driver/compmisc.cmx driver/compenv.cmx utils/clflags.cmx utils/ccomp.cmx \ + driver/compmisc.cmx driver/compenv.cmx utils/clflags.cmx \ bytecomp/bytegen.cmx parsing/builtin_attributes.cmx driver/compile.cmi +driver/compile.cmi : driver/compmisc.cmo : typing/typemod.cmi utils/misc.cmi \ parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ typing/env.cmi utils/config.cmi driver/compenv.cmi utils/clflags.cmi \ @@ -1968,22 +1980,33 @@ driver/compmisc.cmx : typing/typemod.cmx utils/misc.cmx \ parsing/longident.cmx parsing/location.cmx typing/ident.cmx \ typing/env.cmx utils/config.cmx driver/compenv.cmx utils/clflags.cmx \ parsing/asttypes.cmi driver/compmisc.cmi +driver/compmisc.cmi : typing/env.cmi +driver/compplugin.cmo : utils/misc.cmi parsing/location.cmi utils/config.cmi \ + driver/compmisc.cmi driver/compenv.cmi driver/compdynlink.cmi \ + utils/clflags.cmi driver/compplugin.cmi +driver/compplugin.cmx : utils/misc.cmx parsing/location.cmx utils/config.cmx \ + driver/compmisc.cmx driver/compenv.cmx driver/compdynlink.cmi \ + utils/clflags.cmx driver/compplugin.cmi +driver/compplugin.cmi : driver/errors.cmo : parsing/location.cmi driver/errors.cmi driver/errors.cmx : parsing/location.cmx driver/errors.cmi +driver/errors.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 \ - utils/clflags.cmi bytecomp/bytepackager.cmi bytecomp/bytelink.cmi \ - bytecomp/bytelibrarian.cmi driver/main.cmi + driver/compplugin.cmi driver/compmisc.cmi driver/compile.cmi \ + driver/compenv.cmi utils/clflags.cmi bytecomp/bytepackager.cmi \ + bytecomp/bytelink.cmi bytecomp/bytelibrarian.cmi driver/main.cmi driver/main.cmx : utils/warnings.cmx utils/timings.cmx utils/misc.cmx \ driver/main_args.cmx parsing/location.cmx utils/config.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/compplugin.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.cmi : +driver/main_args.cmo : utils/warnings.cmi utils/config.cmi utils/clflags.cmi \ driver/main_args.cmi -driver/main_args.cmx : utils/warnings.cmx utils/clflags.cmx \ +driver/main_args.cmx : utils/warnings.cmx utils/config.cmx utils/clflags.cmx \ driver/main_args.cmi +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 \ @@ -1992,8 +2015,7 @@ driver/optcompile.cmo : utils/warnings.cmi typing/typemod.cmi \ utils/misc.cmi middle_end/middle_end.cmi bytecomp/lambda.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 + 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 \ @@ -2002,44 +2024,35 @@ driver/optcompile.cmx : utils/warnings.cmx typing/typemod.cmx \ utils/misc.cmx middle_end/middle_end.cmx bytecomp/lambda.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 + parsing/builtin_attributes.cmx asmcomp/asmgen.cmx driver/optcompile.cmi +driver/optcompile.cmi : middle_end/backend_intf.cmi driver/opterrors.cmo : parsing/location.cmi driver/opterrors.cmi driver/opterrors.cmx : parsing/location.cmx driver/opterrors.cmi +driver/opterrors.cmi : driver/optmain.cmo : utils/warnings.cmi utils/timings.cmi asmcomp/proc.cmi \ asmcomp/printmach.cmi driver/optcompile.cmi utils/misc.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 + utils/config.cmi driver/compplugin.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/proc.cmx \ asmcomp/printmach.cmx driver/optcompile.cmx utils/misc.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 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 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 -toplevel/opttoploop.cmi : utils/warnings.cmi typing/types.cmi \ - typing/path.cmi parsing/parsetree.cmi typing/outcometree.cmi \ - parsing/longident.cmi parsing/location.cmi typing/env.cmi -toplevel/opttopmain.cmi : -toplevel/topdirs.cmi : parsing/longident.cmi -toplevel/toploop.cmi : utils/warnings.cmi typing/types.cmi typing/path.cmi \ - parsing/parsetree.cmi typing/outcometree.cmi parsing/longident.cmi \ - parsing/location.cmi typing/env.cmi -toplevel/topmain.cmi : -toplevel/trace.cmi : typing/types.cmi typing/path.cmi parsing/longident.cmi \ - typing/env.cmi + utils/config.cmx driver/compplugin.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/optmain.cmi : +driver/pparse.cmo : utils/timings.cmi parsing/parsetree.cmi \ + parsing/parse.cmi utils/misc.cmi parsing/location.cmi utils/config.cmi \ + utils/clflags.cmi utils/ccomp.cmi parsing/ast_mapper.cmi \ + parsing/ast_invariants.cmi driver/pparse.cmi +driver/pparse.cmx : utils/timings.cmx parsing/parsetree.cmi \ + parsing/parse.cmx utils/misc.cmx parsing/location.cmx utils/config.cmx \ + utils/clflags.cmx utils/ccomp.cmx parsing/ast_mapper.cmx \ + parsing/ast_invariants.cmx driver/pparse.cmi +driver/pparse.cmi : parsing/parsetree.cmi utils/misc.cmi toplevel/expunge.cmo : bytecomp/symtable.cmi bytecomp/runtimedef.cmi \ utils/misc.cmi typing/ident.cmi bytecomp/bytesections.cmi toplevel/expunge.cmx : bytecomp/symtable.cmx bytecomp/runtimedef.cmx \ @@ -2054,16 +2067,19 @@ toplevel/genprintval.cmx : typing/types.cmx typing/printtyp.cmx \ typing/oprint.cmx utils/misc.cmx parsing/longident.cmx typing/ident.cmx \ typing/env.cmx typing/datarepr.cmx typing/ctype.cmx typing/btype.cmx \ toplevel/genprintval.cmi +toplevel/genprintval.cmi : typing/types.cmi typing/path.cmi \ + typing/outcometree.cmi typing/env.cmi toplevel/opttopdirs.cmo : utils/warnings.cmi typing/types.cmi \ typing/printtyp.cmi toplevel/opttoploop.cmi utils/misc.cmi \ parsing/longident.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \ - utils/config.cmi utils/clflags.cmi asmcomp/asmlink.cmi \ - toplevel/opttopdirs.cmi + utils/config.cmi driver/compdynlink.cmi utils/clflags.cmi \ + asmcomp/asmlink.cmi toplevel/opttopdirs.cmi toplevel/opttopdirs.cmx : utils/warnings.cmx typing/types.cmx \ typing/printtyp.cmx toplevel/opttoploop.cmx utils/misc.cmx \ parsing/longident.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \ - utils/config.cmx utils/clflags.cmx asmcomp/asmlink.cmx \ - toplevel/opttopdirs.cmi + utils/config.cmx driver/compdynlink.cmi utils/clflags.cmx \ + asmcomp/asmlink.cmx toplevel/opttopdirs.cmi +toplevel/opttopdirs.cmi : parsing/longident.cmi toplevel/opttoploop.cmo : utils/warnings.cmi typing/types.cmi \ typing/typemod.cmi typing/typedtree.cmi typing/typecore.cmi \ bytecomp/translmod.cmi utils/timings.cmi bytecomp/simplif.cmi \ @@ -2075,10 +2091,10 @@ toplevel/opttoploop.cmo : utils/warnings.cmi typing/types.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 middle_end/backend_intf.cmi parsing/asttypes.cmi \ - parsing/ast_helper.cmi asmcomp/asmlink.cmi asmcomp/asmgen.cmi \ - asmcomp/arch.cmo toplevel/opttoploop.cmi + driver/compmisc.cmi asmcomp/compilenv.cmi driver/compdynlink.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 \ @@ -2090,18 +2106,24 @@ toplevel/opttoploop.cmx : utils/warnings.cmx typing/types.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 middle_end/backend_intf.cmi parsing/asttypes.cmi \ - parsing/ast_helper.cmx asmcomp/asmlink.cmx asmcomp/asmgen.cmx \ - asmcomp/arch.cmx toplevel/opttoploop.cmi + driver/compmisc.cmx asmcomp/compilenv.cmx driver/compdynlink.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/opttoploop.cmi : utils/warnings.cmi typing/types.cmi \ + typing/path.cmi parsing/parsetree.cmi typing/outcometree.cmi \ + parsing/longident.cmi parsing/location.cmi typing/env.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 \ - driver/compenv.cmi utils/clflags.cmi toplevel/opttopmain.cmi + driver/compplugin.cmi driver/compenv.cmi utils/clflags.cmi \ + toplevel/opttopmain.cmi toplevel/opttopmain.cmx : utils/warnings.cmx asmcomp/printmach.cmx \ toplevel/opttoploop.cmx toplevel/opttopdirs.cmx utils/misc.cmx \ driver/main_args.cmx parsing/location.cmx utils/config.cmx \ - driver/compenv.cmx utils/clflags.cmx toplevel/opttopmain.cmi + driver/compplugin.cmx driver/compenv.cmx utils/clflags.cmx \ + toplevel/opttopmain.cmi +toplevel/opttopmain.cmi : toplevel/opttopstart.cmo : toplevel/opttopmain.cmi toplevel/opttopstart.cmx : toplevel/opttopmain.cmx toplevel/topdirs.cmo : utils/warnings.cmi typing/typetexp.cmi \ @@ -2122,6 +2144,7 @@ toplevel/topdirs.cmx : utils/warnings.cmx typing/typetexp.cmx \ utils/consistbl.cmx utils/config.cmx bytecomp/cmo_format.cmi \ utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ toplevel/topdirs.cmi +toplevel/topdirs.cmi : parsing/longident.cmi toplevel/toploop.cmo : utils/warnings.cmi typing/typetexp.cmi \ typing/types.cmi typing/typemod.cmi typing/typedtree.cmi \ typing/typecore.cmi bytecomp/translmod.cmi bytecomp/symtable.cmi \ @@ -2133,7 +2156,7 @@ toplevel/toploop.cmo : utils/warnings.cmi typing/typetexp.cmi \ parsing/location.cmi parsing/lexer.cmi typing/includemod.cmi \ typing/ident.cmi toplevel/genprintval.cmi typing/env.cmi \ bytecomp/emitcode.cmi bytecomp/dll.cmi utils/consistbl.cmi \ - utils/config.cmi driver/compmisc.cmi utils/clflags.cmi \ + utils/config.cmi driver/compmisc.cmi driver/compenv.cmi utils/clflags.cmi \ bytecomp/bytegen.cmi typing/btype.cmi parsing/asttypes.cmi \ parsing/ast_helper.cmi toplevel/toploop.cmi toplevel/toploop.cmx : utils/warnings.cmx typing/typetexp.cmx \ @@ -2147,17 +2170,21 @@ toplevel/toploop.cmx : utils/warnings.cmx typing/typetexp.cmx \ parsing/location.cmx parsing/lexer.cmx typing/includemod.cmx \ typing/ident.cmx toplevel/genprintval.cmx typing/env.cmx \ bytecomp/emitcode.cmx bytecomp/dll.cmx utils/consistbl.cmx \ - utils/config.cmx driver/compmisc.cmx utils/clflags.cmx \ + utils/config.cmx driver/compmisc.cmx driver/compenv.cmx utils/clflags.cmx \ bytecomp/bytegen.cmx typing/btype.cmx parsing/asttypes.cmi \ parsing/ast_helper.cmx toplevel/toploop.cmi +toplevel/toploop.cmi : utils/warnings.cmi typing/types.cmi typing/path.cmi \ + parsing/parsetree.cmi typing/outcometree.cmi parsing/longident.cmi \ + parsing/location.cmi typing/env.cmi toplevel/topmain.cmo : utils/warnings.cmi toplevel/toploop.cmi \ toplevel/topdirs.cmi utils/misc.cmi driver/main_args.cmi \ - parsing/location.cmi utils/config.cmi driver/compenv.cmi \ - utils/clflags.cmi toplevel/topmain.cmi + parsing/location.cmi utils/config.cmi driver/compplugin.cmi \ + driver/compenv.cmi utils/clflags.cmi toplevel/topmain.cmi toplevel/topmain.cmx : utils/warnings.cmx toplevel/toploop.cmx \ toplevel/topdirs.cmx utils/misc.cmx driver/main_args.cmx \ - parsing/location.cmx utils/config.cmx driver/compenv.cmx \ - utils/clflags.cmx toplevel/topmain.cmi + parsing/location.cmx utils/config.cmx driver/compplugin.cmx \ + driver/compenv.cmx utils/clflags.cmx toplevel/topmain.cmi +toplevel/topmain.cmi : toplevel/topstart.cmo : toplevel/topmain.cmi toplevel/topstart.cmx : toplevel/topmain.cmx toplevel/trace.cmo : typing/types.cmi toplevel/toploop.cmi \ @@ -2168,3 +2195,10 @@ toplevel/trace.cmx : typing/types.cmx toplevel/toploop.cmx \ typing/printtyp.cmx typing/predef.cmx typing/path.cmx utils/misc.cmx \ bytecomp/meta.cmx parsing/longident.cmx typing/ctype.cmx \ parsing/asttypes.cmi toplevel/trace.cmi +toplevel/trace.cmi : typing/types.cmi typing/path.cmi parsing/longident.cmi \ + typing/env.cmi +driver/compdynlink.cmx : asmcomp/cmx_format.cmi driver/compdynlink.cmi +driver/compdynlink.cmo : bytecomp/symtable.cmi bytecomp/opcodes.cmo \ + utils/misc.cmi bytecomp/meta.cmi bytecomp/dll.cmi utils/consistbl.cmi \ + utils/config.cmi bytecomp/cmo_format.cmi typing/cmi_format.cmi \ + driver/compdynlink.cmi diff --git a/.gitattributes b/.gitattributes index d83330ee..be13cb1a 100644 --- a/.gitattributes +++ b/.gitattributes @@ -17,9 +17,9 @@ * text=auto # Binary files -boot/ocamlc binary -boot/ocamllex binary -boot/ocamldep binary +/boot/ocamlc binary +/boot/ocamllex binary +/boot/ocamldep binary *.gif binary *.png binary *.tfm binary @@ -29,11 +29,12 @@ boot/ocamldep binary README* ocaml-typo=missing-header *.adoc ocaml-typo=missing-header,long-line,unused-prop -/.merlin ocaml-typo=missing-header -/Changes ocaml-typo=non-ascii,missing-header -/INSTALL ocaml-typo=missing-header -/LICENSE ocaml-typo=non-printing,missing-header -/appveyor.yml ocaml-typo=long-line,very-long-line +/.mailmap ocaml-typo=long-line,missing-header,non-ascii +/.merlin ocaml-typo=missing-header +/Changes ocaml-typo=non-ascii,missing-header +/INSTALL ocaml-typo=missing-header +/LICENSE ocaml-typo=long-line,very-long-line,missing-header +/appveyor.yml ocaml-typo=long-line,very-long-line asmcomp/*/emit.mlp ocaml-typo=tab,long-line,unused-prop @@ -63,10 +64,9 @@ otherlibs/win32unix/readlink.c ocaml-typo=long-line otherlibs/win32unix/stat.c ocaml-typo=long-line otherlibs/win32unix/symlink.c ocaml-typo=long-line -stdlib/sharpbang ocaml-typo=white-at-eol,missing-lf +stdlib/hashbang ocaml-typo=white-at-eol,missing-lf -# FIXME remove headers in testsuite/tests and remove unused-prop in next line: -testsuite/tests/** ocaml-typo=missing-header,unused-prop +testsuite/tests/** ocaml-typo=missing-header testsuite/tests/lib-bigarray-2/bigarrf.f ocaml-typo=missing-header,tab testsuite/tests/misc-unsafe/almabench.ml ocaml-typo=missing-header,long-line testsuite/typing ocaml-typo=missing-header @@ -125,3 +125,6 @@ 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 + +# Similarly, the docstring tests fail for the same reason on Windows +testsuite/tests/docstrings/empty.ml text eol=lf diff --git a/.gitignore b/.gitignore index 095b8acf..332ecb86 100644 --- a/.gitignore +++ b/.gitignore @@ -110,6 +110,7 @@ /byterun/caml/version.h /byterun/ocamlrun /byterun/ocamlrund +/byterun/ocamlruni /byterun/ld.conf /byterun/interp.a.lst /byterun/*.[sd]obj @@ -125,8 +126,9 @@ /debugger/parser.ml /debugger/parser.mli /debugger/ocamldebug -/debugger/dynlink.ml -/debugger/dynlink.mli +/driver/compdynlink.mlopt +/driver/compdynlink.mlbyte +/driver/compdynlink.mli /emacs/ocamltags /emacs/*.elc @@ -225,6 +227,7 @@ /testsuite/**/*.result /testsuite/**/*.opt_result +/testsuite/**/*.corrected /testsuite/**/*.byte /testsuite/**/*.native /testsuite/**/program @@ -239,8 +242,14 @@ /testsuite/tests/asmcomp/*.s /testsuite/tests/asmcomp/*.out.manifest +/testsuite/tests/basic/*.safe-string +/testsuite/tests/basic/pr6322.ml + /testsuite/tests/embedded/caml +/testsuite/tests/float-unboxing/*.flambda +/testsuite/tests/float-unboxing/float_inline.ml + /testsuite/tests/lib-dynlink-bytecode/main /testsuite/tests/lib-dynlink-bytecode/static /testsuite/tests/lib-dynlink-bytecode/custom @@ -262,6 +271,8 @@ /testsuite/tests/runtime-errors/*.bytecode +/testsuite/tests/self-contained-toplevel/cached_cmi.ml + /testsuite/tests/tool-debugger/**/compiler-libs /testsuite/tests/tool-debugger/find-artifacts/out /testsuite/tests/tool-debugger/no_debug_event/out @@ -281,10 +292,24 @@ /testsuite/tests/tool-ocamldoc-2/ocamldoc.sty +/testsuite/tests/tool-ocamldoc-html/*.html +/testsuite/tests/tool-ocamldoc-html/style.css + +/testsuite/tests/tool-ocamldoc-man/*.3o + +/testsuite/tests/tool-ocamldoc-open/alias.odoc +/testsuite/tests/tool-ocamldoc-open/inner.odoc +/testsuite/tests/tool-ocamldoc-open/main.odoc +/testsuite/tests/tool-ocamldoc-open/ocamldoc.sty + /testsuite/tests/tool-lexyacc/scanner.ml /testsuite/tests/tool-lexyacc/grammar.mli /testsuite/tests/tool-lexyacc/grammar.ml +/testsuite/tests/typing-multifile/a.ml +/testsuite/tests/typing-multifile/b.ml +/testsuite/tests/typing-multifile/c.ml + /testsuite/tests/unboxed-primitive-args/main.ml /testsuite/tests/unboxed-primitive-args/stubs.c @@ -293,26 +318,37 @@ /testsuite/tests/warnings/w55.opt.opt_result /testsuite/tests/warnings/w58.opt.opt_result +/testsuite/tools/expect_test + /tools/ocamldep /tools/ocamldep.opt /tools/ocamldep.bak /tools/ocamlprof +/tools/ocamlprof.opt /tools/opnames.ml /tools/dumpobj +/tools/dumpobj.opt /tools/dumpapprox -/tools/objinfo +/tools/ocamlobjinfo +/tools/ocamlobjinfo.opt /tools/cvt_emit +/tools/cvt_emit.opt /tools/cvt_emit.bak /tools/cvt_emit.ml /tools/ocamlcp +/tools/ocamlcp.opt /tools/ocamloptp +/tools/ocamloptp.opt /tools/ocamlmktop +/tools/ocamlmktop.opt /tools/primreq +/tools/primreq.opt /tools/ocamldumpobj /tools/keywords /tools/lexer299.ml /tools/ocaml299to3 /tools/ocamlmklib +/tools/ocamlmklib.opt /tools/ocamlmklibconfig.ml /tools/lexer301.ml /tools/scrapelabels @@ -321,7 +357,9 @@ /tools/read_cmt /tools/read_cmt.opt /tools/cmpbyt +/tools/cmpbyt.opt /tools/stripdebug +/tools/stripdebug.opt /utils/config.ml diff --git a/.mailmap b/.mailmap new file mode 100644 index 00000000..96b52348 --- /dev/null +++ b/.mailmap @@ -0,0 +1,76 @@ +# The format of this file is generally of the form +# +# for example: +# Proper Name +# +# Proper Name Commit Name +# +# See the MAPPING AUTHORS section of 'man git-shortlog' for more details. + +# Such a remapping may be useful in particular for tracking authorship +# of commits erroneously made under an obscure alias or email adress. +# (Some Name , pour ne pas le citer) + +Alain Frisch alainfrisch + + + + + + + + +cvs2svn +Damien Doligez Some Name +Damien Doligez doligez +Mohamed Iguernelala +Jérémie Dimino + +# The aliases below correspond to preference expressed by +# contributors on the name under which they credited, for example +# if they use an opaque nickname from github or mantis: +# +# Preferred Name nickname +# or +# Preferred Name +# Preferred Name @github.com +# to indicate a preference associated to a Mantis account. + +Florian Angeletti octachron +Gabriel Radanne Drup +Pierre Weis pierreweis +John Christopher McAlpine chrismamo1 +Runhang Li marklrh +Francis Souther FDSouthern +Simon Cruanes +Frederic Bour +David Sheets +David Allsopp +Tim Cuthbertson +Grégoire Henry +Julien Moutinho +Adam Borowski +Mikhail Mandrykin +Maverick Woo +Andi McClure +Michael Grünewald +Michael O'Connor +Florian Angeletti +Kenji Tokudome +Philippe Veber +Valentin Gatien-Baron +Stephen Dolan +Junsong Li +Junsong Li +Christophe Raffali +Anton Bachin +Reed Wilson +David Scott +Martin Neuhäußer +Goswin von Brederlow + +# These contributors prefer to be referred to pseudonymously + + +tkob tkob +ygrek ygrek diff --git a/.travis-ci.sh b/.travis-ci.sh index 8f847924..a0df8aa1 100755 --- a/.travis-ci.sh +++ b/.travis-ci.sh @@ -21,7 +21,7 @@ BuildAndTest () { echo< raise e` (Nicolas Ojeda Bar, review by Gabriel Scherer) -Runtime system: -=============== +### Runtime system: + +* GPR#596: make string/bytes distinguishable in the underlying + compiler implementation; caml_fill_string and caml_create_string are + deprecated and will be removed in the future, please use + caml_fill_bytes and caml_create_bytes for migration + (Hongbo Zhang, review by Damien Doligez, Alain Frisch, and Hugo Heuzard) + +- GPR#772 %string_safe_set and %string_unsafe_set are deprecated aliases + for %bytes_safe_set and %bytes_unsafe_set. + (Hongbo Zhang and Damien Doligez) - PR#3612, PR#92: allow allocating custom block with finalizers in the minor heap. @@ -325,8 +732,7 @@ Runtime system: - GPR#325: Add v=0x400 flag to OCAMLRUNPARAM to display GC stats on exit (Louis Gesbert, review by Alain Frisch) -Standard library: -================= +### Standard library: - PR#1460, GPR#230: Array.map2, Array.iter2 (John Christopher McAlpine) @@ -450,8 +856,7 @@ Standard library: - GPR#356: Add [Format.kasprintf] (Jérémie Dimino, Mark Shinwell) -Type system: -============ +### Type system: - PR#5545: Type annotations on methods cannot control the choice of abbreviation (Jacques Garrigue) @@ -465,8 +870,7 @@ Type system: - PR#6593: Functor application in tests/basic-modules fails after commit 15405 (Jacques Garrigue) -Toplevel and debugger: -====================== +### Toplevel and debugger: - PR#6113: Add descriptions to directives, and display them via #help (Nick Giannarakis, Berke Durak, Francis Southern and Gabriel Scherer) @@ -501,8 +905,7 @@ Toplevel and debugger: - PR#7119: the toplevel does not respect [@@@warning] (Alain Frisch, report by Gabriel Radanne) -Other libraries: -================ +### Other libraries: * Unix library: channels created by Unix.in_channel_of_descr or Unix.out_channel_of_descr no longer support text mode under Windows. @@ -552,14 +955,12 @@ Other libraries: similar functions when the [exec] call fails in the child process (Jérémie Dimino) -OCamldep: -========= +### OCamldep: - GPR#286: add support for module aliases (Jacques Garrigue) -Manual: -======= +### Manual: - GPR#302: The OCaml reference manual is now included in the manual/ subdirectory of the main OCaml source repository. Contributions to @@ -588,8 +989,7 @@ Manual: - PR#7109, GPR#380: Fix bigarray documentation layout (Florian Angeletti, Leo White) -Bug fixes: -========== +### Bug fixes: - PR#3612: memory leak in bigarray read from file (Pierre Chambart, report by Gary Huber) @@ -821,7 +1221,10 @@ Bug fixes: - PR#7135: only warn about ground coercions in -principal mode (Jacques Garrigue, report by Jeremy Yallop) -- PR#7152: Typing equality involving non-generalizable type variable +* PR#7152: Typing equality involving non-generalizable type variable + A side-effect of the fix is that, for deeply nested non generalizable + type variables, having an interface file may no longer be sufficient, + and you may have to add a local type annotation (cf PR#7313) (Jacques Garrigue, report by François Bobot) - PR#7160: Type synonym definitions can weaken gadt constructor types @@ -851,6 +1254,13 @@ Bug fixes: - PR#7234: Compatibility check wrong for abstract type constructors (Jacques Garrigue, report by Stephen Dolan) +- PR#7324: OCaml 4.03.0 type checker dies with an assert failure when + given some cyclic recusive module expression + (Jacques Garrigue, report by jmcarthur) + +- PR#7368: Manual major GC fails to compact the heap + (Krzysztof Pszeniczny) + - GPR#205: Clear caml_backtrace_last_exn before registering as root (report and fix by Frederic Bour) @@ -902,8 +1312,7 @@ Bug fixes: variant and arrow types (Thomas Refis) -Features wishes: -================ +### Features wishes: - PR#4518, GPR#29: change location format for reporting errors in ocamldoc (Sergei Lebedev) @@ -1030,8 +1439,7 @@ Features wishes: (Mark Shinwell, debugging & test case by Arseniy Alekseyev and Leo White, code review by Xavier Leroy) -Build system: -============= +### Build system: - GPR#388: FlexDLL added as a Git submodule and bootstrappable with the compiler (David Allsopp) diff --git a/LICENSE b/LICENSE index 515f12e7..3666ebe1 100644 --- a/LICENSE +++ b/LICENSE @@ -1,627 +1,203 @@ -In the following, "the Library" refers to all files marked "Copyright -INRIA" in the following directories and their sub-directories: - - asmrun, byterun, config, otherlibs, stdlib, win32caml - -and "the Compiler" refers to all files marked "Copyright INRIA" in the -following directories and their sub-directories: - - asmcomp, boot, build, bytecomp, debugger, driver, lex, man, - ocamldoc, parsing, testsuite, tools, toplevel, typing, - utils, yacc - -The Compiler is distributed under the terms of the Q Public License -version 1.0 with a change to choice of law (included below). - -The Library is distributed under the terms of the GNU Library General -Public License version 2 (included below). - -As a special exception to the Q Public Licence, you may develop -application programs, reusable components and other software items -that link with the original or modified versions of the Compiler -and are not made available to the general public, without any of the -additional requirements listed in clause 6c of the Q Public licence. - -As a special exception to the GNU Library General Public License, you -may link, statically or dynamically, a "work that uses the Library" -with a publicly distributed version of the Library to produce an -executable file containing portions of the Library, and distribute -that executable file under terms of your choice, without any of the -additional requirements listed in clause 6 of the GNU Library General -Public License. By "a publicly distributed version of the Library", -we mean either the unmodified Library as distributed by INRIA, or a -modified version of the Library that is distributed under the -conditions defined in clause 2 of the GNU Library General Public -License. This exception does not however invalidate any other reasons -why the executable file might be covered by the GNU Library General -Public License. +In the following, "the OCaml Core System" refers to all files marked +"Copyright INRIA" in this distribution. + +The OCaml Core System is distributed under the terms of the +GNU Lesser General Public License (LGPL) version 2.1 (included below). + +As a special exception to the GNU Lesser General Public License, you +may link, statically or dynamically, a "work that uses the OCaml Core +System" with a publicly distributed version of the OCaml Core System +to produce an executable file containing portions of the OCaml Core +System, and distribute that executable file under terms of your +choice, without any of the additional requirements listed in clause 6 +of the GNU Lesser General Public License. By "a publicly distributed +version of the OCaml Core System", we mean either the unmodified OCaml +Core System as distributed by INRIA, or a modified version of the +OCaml Core System that is distributed under the conditions defined in +clause 2 of the GNU Lesser General Public License. This exception +does not however invalidate any other reasons why the executable file +might be covered by the GNU Lesser General Public License. ---------------------------------------------------------------------- - THE Q PUBLIC LICENSE version 1.0 +GNU LESSER GENERAL PUBLIC LICENSE - Copyright (C) 1999 Troll Tech AS, Norway. - Everyone is permitted to copy and - distribute this license document. +Version 2.1, February 1999 -The intent of this license is to establish freedom to share and change -the software regulated by this license under the open source model. +Copyright (C) 1991, 1999 Free Software Foundation, Inc. +51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +Everyone is permitted to copy and distribute verbatim copies +of this license document, but changing it is not allowed. -This license applies to any software containing a notice placed by the -copyright holder saying that it may be distributed under the terms of -the Q Public License version 1.0. Such software is herein referred to -as the Software. This license covers modification and distribution of -the Software, use of third-party application programs based on the -Software, and development of free software which uses the Software. +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] - Granted Rights +Preamble -1. You are granted the non-exclusive rights set forth in this license -provided you agree to and comply with any and all conditions in this -license. Whole or partial distribution of the Software, or software -items that link with the Software, in any form signifies acceptance of -this license. +The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. -2. You may copy and distribute the Software in unmodified form -provided that the entire package, including - but not restricted to - -copyright, trademark notices and disclaimers, as released by the -initial developer of the Software, is distributed. +This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below. -3. You may make modifications to the Software and distribute your -modifications, in a form that is separate from the Software, such as -patches. The following restrictions apply to modifications: +When we speak of free software, we are referring to freedom of use, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things. - a. Modifications must not alter or remove any copyright notices - in the Software. +To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it. - b. When modifications to the Software are released under this - license, a non-exclusive royalty-free right is granted to the - initial developer of the Software to distribute your - modification in future versions of the Software provided such - versions remain available under these terms in addition to any - other license(s) of the initial developer. +For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights. -4. You may distribute machine-executable forms of the Software or -machine-executable forms of modified versions of the Software, -provided that you meet these restrictions: +We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library. - a. You must include this license document in the distribution. +To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others. - b. You must ensure that all recipients of the machine-executable - forms are also able to receive the complete machine-readable - source code to the distributed Software, including all - modifications, without any charge beyond the costs of data - transfer, and place prominent notices in the distribution - explaining this. +Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license. - c. You must ensure that all modifications included in the - machine-executable forms are available under the terms of this - license. +Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs. -5. You may use the original or modified versions of the Software to -compile, link and run application programs legally developed by you or -by others. +When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library. -6. You may develop application programs, reusable components and other -software items that link with the original or modified versions of the -Software. These items, when distributed, are subject to the following -requirements: +We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances. - a. You must ensure that all recipients of machine-executable - forms of these items are also able to receive and use the - complete machine-readable source code to the items without any - charge beyond the costs of data transfer. +For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License. - b. You must explicitly license all recipients of your items to - use and re-distribute original and modified versions of the - items in both machine-executable and source code forms. The - recipients must be able to do so without any charges whatsoever, - and they must be able to re-distribute to anyone they choose. +In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system. - c. If the items are not available to the general public, and the - initial developer of the Software requests a copy of the items, - then you must supply one. +Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library. - Limitations of Liability +The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run. -In no event shall the initial developers or copyright holders be -liable for any damages whatsoever, including - but not restricted to - -lost revenue or profits or other direct, indirect, special, incidental -or consequential damages, even if they have been advised of the -possibility of such damages, except to the extent invariable law, if -any, provides otherwise. +TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - No Warranty +0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you". -The Software and this license document are provided AS IS with NO -WARRANTY OF ANY KIND, INCLUDING THE WARRANTY OF DESIGN, -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. +A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. - Choice of Law +The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) -This license is governed by the Laws of France. +"Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. ----------------------------------------------------------------------- +Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. + +1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. + +You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. - GNU LIBRARY GENERAL PUBLIC LICENSE - Version 2, June 1991 - - Copyright (C) 1991 Free Software Foundation, Inc. - 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - -[This is the first released version of the library GPL. It is - numbered 2 because it goes with version 2 of the ordinary GPL.] - - Preamble - - The licenses for most software are designed to take away your -freedom to share and change it. By contrast, the GNU General Public -Licenses are intended to guarantee your freedom to share and change -free software--to make sure the software is free for all its users. - - This license, the Library General Public License, applies to some -specially designated Free Software Foundation software, and to any -other libraries whose authors decide to use it. You can use it for -your libraries, too. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -this service if you wish), that you receive source code or can get it -if you want it, that you can change the software or use pieces of it -in new free programs; and that you know you can do these things. - - To protect your rights, we need to make restrictions that forbid -anyone to deny you these rights or to ask you to surrender the rights. -These restrictions translate to certain responsibilities for you if -you distribute copies of the library, or if you modify it. - - For example, if you distribute copies of the library, whether gratis -or for a fee, you must give the recipients all the rights that we gave -you. You must make sure that they, too, receive or can get the source -code. If you link a program with the library, you must provide -complete object files to the recipients so that they can relink them -with the library, after making changes to the library and recompiling -it. And you must show them these terms so they know their rights. - - Our method of protecting your rights has two steps: (1) copyright -the library, and (2) offer you this license which gives you legal -permission to copy, distribute and/or modify the library. - - Also, for each distributor's protection, we want to make certain -that everyone understands that there is no warranty for this free -library. If the library is modified by someone else and passed on, we -want its recipients to know that what they have is not the original -version, so that any problems introduced by others will not reflect on -the original authors' reputations. - - Finally, any free program is threatened constantly by software -patents. We wish to avoid the danger that companies distributing free -software will individually obtain patent licenses, thus in effect -transforming the program into proprietary software. To prevent this, -we have made it clear that any patent must be licensed for everyone's -free use or not licensed at all. - - Most GNU software, including some libraries, is covered by the ordinary -GNU General Public License, which was designed for utility programs. This -license, the GNU Library General Public License, applies to certain -designated libraries. This license is quite different from the ordinary -one; be sure to read it in full, and don't assume that anything in it is -the same as in the ordinary license. - - The reason we have a separate public license for some libraries is that -they blur the distinction we usually make between modifying or adding to a -program and simply using it. Linking a program with a library, without -changing the library, is in some sense simply using the library, and is -analogous to running a utility program or application program. However, in -a textual and legal sense, the linked executable is a combined work, a -derivative of the original library, and the ordinary General Public License -treats it as such. - - Because of this blurred distinction, using the ordinary General -Public License for libraries did not effectively promote software -sharing, because most developers did not use the libraries. We -concluded that weaker conditions might promote sharing better. - - However, unrestricted linking of non-free programs would deprive the -users of those programs of all benefit from the free status of the -libraries themselves. This Library General Public License is intended to -permit developers of non-free programs to use free libraries, while -preserving your freedom as a user of such programs to change the free -libraries that are incorporated in them. (We have not seen how to achieve -this as regards changes in header files, but we have achieved it as regards -changes in the actual functions of the Library.) The hope is that this -will lead to faster development of free libraries. - - The precise terms and conditions for copying, distribution and -modification follow. Pay close attention to the difference between a -"work based on the library" and a "work that uses the library". The -former contains code derived from the library, while the latter only -works together with the library. - - Note that it is possible for a library to be covered by the ordinary -General Public License rather than by this special one. - - GNU LIBRARY GENERAL PUBLIC LICENSE - TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - - 0. This License Agreement applies to any software library which -contains a notice placed by the copyright holder or other authorized -party saying it may be distributed under the terms of this Library -General Public License (also called "this License"). Each licensee is -addressed as "you". - - A "library" means a collection of software functions and/or data -prepared so as to be conveniently linked with application programs -(which use some of those functions and data) to form executables. - - The "Library", below, refers to any such software library or work -which has been distributed under these terms. A "work based on the -Library" means either the Library or any derivative work under -copyright law: that is to say, a work containing the Library or a -portion of it, either verbatim or with modifications and/or translated -straightforwardly into another language. (Hereinafter, translation is -included without limitation in the term "modification".) - - "Source code" for a work means the preferred form of the work for -making modifications to it. For a library, complete source code means -all the source code for all modules it contains, plus any associated -interface definition files, plus the scripts used to control compilation -and installation of the library. - - Activities other than copying, distribution and modification are not -covered by this License; they are outside its scope. The act of -running a program using the Library is not restricted, and output from -such a program is covered only if its contents constitute a work based -on the Library (independent of the use of the Library in a tool for -writing it). Whether that is true depends on what the Library does -and what the program that uses the Library does. - - 1. You may copy and distribute verbatim copies of the Library's -complete source code as you receive it, in any medium, provided that -you conspicuously and appropriately publish on each copy an -appropriate copyright notice and disclaimer of warranty; keep intact -all the notices that refer to this License and to the absence of any -warranty; and distribute a copy of this License along with the -Library. - - You may charge a fee for the physical act of transferring a copy, -and you may at your option offer warranty protection in exchange for a -fee. - - 2. You may modify your copy or copies of the Library or any portion -of it, thus forming a work based on the Library, and copy and -distribute such modifications or work under the terms of Section 1 -above, provided that you also meet all of these conditions: +2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. + b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. + c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. + d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. + + (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. + +3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. + +Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. + +This option is useful when you wish to copy part of the code of the Library into a program that is not a library. + +4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. + +If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. + +5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. + +However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. + +When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. + +If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) + +Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. + +6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. + +You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: + + a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) + b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. + c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. + d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. + e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. + +For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. + +It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. + +7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: - b) You must cause the files modified to carry prominent notices - stating that you changed the files and the date of any change. - - c) You must cause the whole of the work to be licensed at no - charge to all third parties under the terms of this License. - - d) If a facility in the modified Library refers to a function or a - table of data to be supplied by an application program that uses - the facility, other than as an argument passed when the facility - is invoked, then you must make a good faith effort to ensure that, - in the event an application does not supply such function or - table, the facility still operates, and performs whatever part of - its purpose remains meaningful. - - (For example, a function in a library to compute square roots has - a purpose that is entirely well-defined independent of the - application. Therefore, Subsection 2d requires that any - application-supplied function or table used by this function must - be optional: if the application does not supply it, the square - root function must still compute square roots.) - -These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the Library, -and can be reasonably considered independent and separate works in -themselves, then this License, and its terms, do not apply to those -sections when you distribute them as separate works. But when you -distribute the same sections as part of a whole which is a work based -on the Library, the distribution of the whole must be on the terms of -this License, whose permissions for other licensees extend to the -entire whole, and thus to each and every part regardless of who wrote -it. - -Thus, it is not the intent of this section to claim rights or contest -your rights to work written entirely by you; rather, the intent is to -exercise the right to control the distribution of derivative or -collective works based on the Library. - -In addition, mere aggregation of another work not based on the Library -with the Library (or with a work based on the Library) on a volume of -a storage or distribution medium does not bring the other work under -the scope of this License. - - 3. You may opt to apply the terms of the ordinary GNU General Public -License instead of this License to a given copy of the Library. To do -this, you must alter all the notices that refer to this License, so -that they refer to the ordinary GNU General Public License, version 2, -instead of to this License. (If a newer version than version 2 of the -ordinary GNU General Public License has appeared, then you can specify -that version instead if you wish.) Do not make any other change in -these notices. - - Once this change is made in a given copy, it is irreversible for -that copy, so the ordinary GNU General Public License applies to all -subsequent copies and derivative works made from that copy. - - This option is useful when you wish to copy part of the code of -the Library into a program that is not a library. - - 4. You may copy and distribute the Library (or a portion or -derivative of it, under Section 2) in object code or executable form -under the terms of Sections 1 and 2 above provided that you accompany -it with the complete corresponding machine-readable source code, which -must be distributed under the terms of Sections 1 and 2 above on a -medium customarily used for software interchange. - - If distribution of object code is made by offering access to copy -from a designated place, then offering equivalent access to copy the -source code from the same place satisfies the requirement to -distribute the source code, even though third parties are not -compelled to copy the source along with the object code. - - 5. A program that contains no derivative of any portion of the -Library, but is designed to work with the Library by being compiled or -linked with it, is called a "work that uses the Library". Such a -work, in isolation, is not a derivative work of the Library, and -therefore falls outside the scope of this License. - - However, linking a "work that uses the Library" with the Library -creates an executable that is a derivative of the Library (because it -contains portions of the Library), rather than a "work that uses the -library". The executable is therefore covered by this License. -Section 6 states terms for distribution of such executables. - - When a "work that uses the Library" uses material from a header file -that is part of the Library, the object code for the work may be a -derivative work of the Library even though the source code is not. -Whether this is true is especially significant if the work can be -linked without the Library, or if the work is itself a library. The -threshold for this to be true is not precisely defined by law. - - If such an object file uses only numerical parameters, data -structure layouts and accessors, and small macros and small inline -functions (ten lines or less in length), then the use of the object -file is unrestricted, regardless of whether it is legally a derivative -work. (Executables containing this object code plus portions of the -Library will still fall under Section 6.) - - Otherwise, if the work is a derivative of the Library, you may -distribute the object code for the work under the terms of Section 6. -Any executables containing that work also fall under Section 6, -whether or not they are linked directly with the Library itself. - - 6. As an exception to the Sections above, you may also compile or -link a "work that uses the Library" with the Library to produce a -work containing portions of the Library, and distribute that work -under terms of your choice, provided that the terms permit -modification of the work for the customer's own use and reverse -engineering for debugging such modifications. - - You must give prominent notice with each copy of the work that the -Library is used in it and that the Library and its use are covered by -this License. You must supply a copy of this License. If the work -during execution displays copyright notices, you must include the -copyright notice for the Library among them, as well as a reference -directing the user to the copy of this License. Also, you must do one -of these things: - - a) Accompany the work with the complete corresponding - machine-readable source code for the Library including whatever - changes were used in the work (which must be distributed under - Sections 1 and 2 above); and, if the work is an executable linked - with the Library, with the complete machine-readable "work that - uses the Library", as object code and/or source code, so that the - user can modify the Library and then relink to produce a modified - executable containing the modified Library. (It is understood - that the user who changes the contents of definitions files in the - Library will not necessarily be able to recompile the application - to use the modified definitions.) - - b) Accompany the work with a written offer, valid for at - least three years, to give the same user the materials - specified in Subsection 6a, above, for a charge no more - than the cost of performing this distribution. - - c) If distribution of the work is made by offering access to copy - from a designated place, offer equivalent access to copy the above - specified materials from the same place. - - d) Verify that the user has already received a copy of these - materials or that you have already sent this user a copy. - - For an executable, the required form of the "work that uses the -Library" must include any data and utility programs needed for -reproducing the executable from it. However, as a special exception, -the source code distributed need not include anything that is normally -distributed (in either source or binary form) with the major -components (compiler, kernel, and so on) of the operating system on -which the executable runs, unless that component itself accompanies -the executable. - - It may happen that this requirement contradicts the license -restrictions of other proprietary libraries that do not normally -accompany the operating system. Such a contradiction means you cannot -use both them and the Library together in an executable that you -distribute. - - 7. You may place library facilities that are a work based on the -Library side-by-side in a single library together with other library -facilities not covered by this License, and distribute such a combined -library, provided that the separate distribution of the work based on -the Library and of the other library facilities is otherwise -permitted, and provided that you do these two things: - - a) Accompany the combined library with a copy of the same work - based on the Library, uncombined with any other library - facilities. This must be distributed under the terms of the - Sections above. - - b) Give prominent notice with the combined library of the fact - that part of it is a work based on the Library, and explaining - where to find the accompanying uncombined form of the same work. - - 8. You may not copy, modify, sublicense, link with, or distribute -the Library except as expressly provided under this License. Any -attempt otherwise to copy, modify, sublicense, link with, or -distribute the Library is void, and will automatically terminate your -rights under this License. However, parties who have received copies, -or rights, from you under this License will not have their licenses -terminated so long as such parties remain in full compliance. - - 9. You are not required to accept this License, since you have not -signed it. However, nothing else grants you permission to modify or -distribute the Library or its derivative works. These actions are -prohibited by law if you do not accept this License. Therefore, by -modifying or distributing the Library (or any work based on the -Library), you indicate your acceptance of this License to do so, and -all its terms and conditions for copying, distributing or modifying -the Library or works based on it. - - 10. Each time you redistribute the Library (or any work based on the -Library), the recipient automatically receives a license from the -original licensor to copy, distribute, link with or modify the Library -subject to these terms and conditions. You may not impose any further -restrictions on the recipients' exercise of the rights granted herein. -You are not responsible for enforcing compliance by third parties to -this License. - - 11. If, as a consequence of a court judgment or allegation of patent -infringement or for any other reason (not limited to patent issues), -conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot -distribute so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you -may not distribute the Library at all. For example, if a patent -license would not permit royalty-free redistribution of the Library by -all those who receive copies directly or indirectly through you, then -the only way you could satisfy both it and this License would be to -refrain entirely from distribution of the Library. - -If any portion of this section is held invalid or unenforceable under any -particular circumstance, the balance of the section is intended to apply, -and the section as a whole is intended to apply in other circumstances. - -It is not the purpose of this section to induce you to infringe any -patents or other property right claims or to contest validity of any -such claims; this section has the sole purpose of protecting the -integrity of the free software distribution system which is -implemented by public license practices. Many people have made -generous contributions to the wide range of software distributed -through that system in reliance on consistent application of that -system; it is up to the author/donor to decide if he or she is willing -to distribute software through any other system and a licensee cannot -impose that choice. - -This section is intended to make thoroughly clear what is believed to -be a consequence of the rest of this License. - - 12. If the distribution and/or use of the Library is restricted in -certain countries either by patents or by copyrighted interfaces, the -original copyright holder who places the Library under this License may add -an explicit geographical distribution limitation excluding those countries, -so that distribution is permitted only in or among countries not thus -excluded. In such case, this License incorporates the limitation as if -written in the body of this License. - - 13. The Free Software Foundation may publish revised and/or new -versions of the Library General Public License from time to time. -Such new versions will be similar in spirit to the present version, -but may differ in detail to address new problems or concerns. - -Each version is given a distinguishing version number. If the Library -specifies a version number of this License which applies to it and -"any later version", you have the option of following the terms and -conditions either of that version or of any later version published by -the Free Software Foundation. If the Library does not specify a -license version number, you may choose any version ever published by -the Free Software Foundation. - - 14. If you wish to incorporate parts of the Library into other free -programs whose distribution conditions are incompatible with these, -write to the author to ask for permission. For software which is -copyrighted by the Free Software Foundation, write to the Free -Software Foundation; we sometimes make exceptions for this. Our -decision will be guided by the two goals of preserving the free status -of all derivatives of our free software and of promoting the sharing -and reuse of software generally. - - NO WARRANTY - - 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO -WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. -EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR -OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY -KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE -LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME -THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. - - 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN -WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY -AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU -FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR -CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE -LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING -RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A -FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF -SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH -DAMAGES. - - END OF TERMS AND CONDITIONS - - Appendix: How to Apply These Terms to Your New Libraries - - If you develop a new library, and you want it to be of the greatest -possible use to the public, we recommend making it free software that -everyone can redistribute and change. You can do so by permitting -redistribution under these terms (or, alternatively, under the terms of the -ordinary General Public License). - - To apply these terms, attach the following notices to the library. It is -safest to attach them to the start of each source file to most effectively -convey the exclusion of warranty; and each file should have at least the -"copyright" line and a pointer to where the full notice is found. - - - Copyright (C) - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free - Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, - MA 02111-1307, USA + a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. + b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. + +8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. + +9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. + +10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License. + +11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. + +This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. + +12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. + +13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. + +14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. + +NO WARRANTY + +15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + +16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. +END OF TERMS AND CONDITIONS + +How to Apply These Terms to Your New Libraries + +If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). + +To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. + +one line to give the library's name and an idea of what it does. +Copyright (C) year name of author + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 2.1 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Lesser General Public License for more details. + +You should have received a copy of the GNU Lesser General Public +License along with this library; if not, write to the Free Software +Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. -You should also get your employer (if you work as a programmer) or your -school, if any, to sign a "copyright disclaimer" for the library, if -necessary. Here is a sample; alter the names: +You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: - Yoyodyne, Inc., hereby disclaims all copyright interest in the - library `Frob' (a library for tweaking knobs) written by James Random Hacker. +Yoyodyne, Inc., hereby disclaims all copyright interest in +the library `Frob' (a library for tweaking knobs) written +by James Random Hacker. - , 1 April 1990 - Ty Coon, President of Vice +signature of Ty Coon, 1 April 1990 +Ty Coon, President of Vice That's all there is to it! + +-------------------------------------------------- diff --git a/Makefile b/Makefile index 75c7973b..85be2db2 100644 --- a/Makefile +++ b/Makefile @@ -48,6 +48,9 @@ world.opt: $(MAKE) coldstart $(MAKE) opt.opt +reconfigure: + ./configure $(CONFIGURE_ARGS) + # Hard bootstrap how-to: # (only necessary in some cases, for example if you remove some primitive) # @@ -95,7 +98,8 @@ coldstart: cp byterun/ocamlrun$(EXE) boot/ocamlrun$(EXE) cd yacc; $(MAKE) all cp yacc/ocamlyacc$(EXE) boot/ocamlyacc$(EXE) - cd stdlib; $(MAKE) COMPILER=../boot/ocamlc all + cd stdlib; \ + $(MAKE) COMPILER="../boot/ocamlc -use-prims ../byterun/primitives" all cd stdlib; cp $(LIBFILES) ../boot if test -f boot/libcamlrun.a; then :; else \ ln -s ../byterun/libcamlrun.a boot/libcamlrun.a; fi @@ -220,10 +224,10 @@ install: dllbigarray$(EXT_DLL) dllnums$(EXT_DLL) dllthreads$(EXT_DLL) \ dllunix$(EXT_DLL) dllgraphics$(EXT_DLL) dllstr$(EXT_DLL) cd byterun; $(MAKE) install - cp ocamlc $(INSTALL_BINDIR)/ocamlc$(EXE) + cp ocamlc $(INSTALL_BINDIR)/ocamlc.byte$(EXE) cp ocaml $(INSTALL_BINDIR)/ocaml$(EXE) cd stdlib; $(MAKE) install - cp lex/ocamllex $(INSTALL_BINDIR)/ocamllex$(EXE) + cp lex/ocamllex $(INSTALL_BINDIR)/ocamllex.byte$(EXE) cp $(CAMLYACC)$(EXE) $(INSTALL_BINDIR)/ocamlyacc$(EXE) cp utils/*.cmi utils/*.cmt utils/*.cmti \ parsing/*.cmi parsing/*.cmt parsing/*.cmti \ @@ -244,12 +248,16 @@ install: if test -n "$(WITH_OCAMLDOC)"; then (cd ocamldoc; $(MAKE) install); fi if test -n "$(WITH_DEBUGGER)"; then (cd debugger; $(MAKE) install); fi cp config/Makefile $(INSTALL_LIBDIR)/Makefile.config - if test -f ocamlopt; then $(MAKE) installopt; fi + if test -f ocamlopt; then $(MAKE) installopt; else \ + cd $(INSTALL_BINDIR); \ + ln -sf ocamlc.byte$(EXE) ocamlc$(EXE); \ + ln -sf ocamllex.byte$(EXE) ocamllex$(EXE); \ + fi # Installation of the native-code compiler installopt: cd asmrun; $(MAKE) install - cp ocamlopt $(INSTALL_BINDIR)/ocamlopt$(EXE) + cp ocamlopt $(INSTALL_BINDIR)/ocamlopt.byte$(EXE) cd stdlib; $(MAKE) installopt cp middle_end/*.cmi middle_end/*.cmt middle_end/*.cmti \ $(INSTALL_COMPLIBDIR) @@ -261,13 +269,18 @@ installopt: else :; fi for i in $(OTHERLIBRARIES); \ do (cd otherlibs/$$i; $(MAKE) installopt) || exit $$?; done - if test -f ocamlopt.opt ; then $(MAKE) installoptopt; fi + if test -f ocamlopt.opt ; then $(MAKE) installoptopt; else \ + cd $(INSTALL_BINDIR); ln -sf ocamlopt.byte$(EXE) ocamlopt$(EXE); fi cd tools; $(MAKE) installopt installoptopt: cp ocamlc.opt $(INSTALL_BINDIR)/ocamlc.opt$(EXE) cp ocamlopt.opt $(INSTALL_BINDIR)/ocamlopt.opt$(EXE) cp lex/ocamllex.opt $(INSTALL_BINDIR)/ocamllex.opt$(EXE) + cd $(INSTALL_BINDIR); \ + ln -sf ocamlc.opt$(EXE) ocamlc$(EXE); \ + ln -sf ocamlopt.opt$(EXE) ocamlopt$(EXE); \ + ln -sf ocamllex.opt$(EXE) ocamllex$(EXE) cp utils/*.cmx parsing/*.cmx typing/*.cmx bytecomp/*.cmx \ driver/*.cmx asmcomp/*.cmx $(INSTALL_COMPLIBDIR) cp compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.a \ @@ -323,9 +336,11 @@ compilerlibs/ocamloptcomp.cma: $(MIDDLE_END) $(ASMCOMP) partialclean:: rm -f compilerlibs/ocamloptcomp.cma -ocamlopt: compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART) +ocamlopt: compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma \ + compilerlibs/ocamlbytecomp.cma $(OPTSTART) $(CAMLC) $(LINKFLAGS) -o ocamlopt \ - compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART) + compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma \ + compilerlibs/ocamlbytecomp.cma $(OPTSTART) partialclean:: rm -f ocamlopt @@ -372,12 +387,10 @@ partialclean:: rm -f compilerlibs/ocamlopttoplevel.cmxa ocamlnat: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ - otherlibs/dynlink/dynlink.cmxa compilerlibs/ocamlopttoplevel.cmxa \ + compilerlibs/ocamlbytecomp.cmxa \ + compilerlibs/ocamlopttoplevel.cmxa \ $(OPTTOPLEVELSTART:.cmo=.cmx) - $(CAMLOPT) $(LINKFLAGS) -linkall -o ocamlnat \ - otherlibs/dynlink/dynlink.cmxa compilerlibs/ocamlcommon.cmxa \ - compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamlopttoplevel.cmxa \ - $(OPTTOPLEVELSTART:.cmo=.cmx) + $(CAMLOPT) $(LINKFLAGS) -linkall -o $@ $^ partialclean:: rm -f ocamlnat @@ -414,12 +427,17 @@ utils/config.ml: utils/config.mlp config/Makefile -e 's|%%ASM%%|$(ASM)|' \ -e 's|%%ASM_CFI_SUPPORTED%%|$(ASM_CFI_SUPPORTED)|' \ -e 's|%%WITH_FRAME_POINTERS%%|$(WITH_FRAME_POINTERS)|' \ + -e 's|%%WITH_SPACETIME%%|$(WITH_SPACETIME)|' \ + -e 's|%%PROFINFO_WIDTH%%|$(PROFINFO_WIDTH)|' \ + -e 's|%%LIBUNWIND_AVAILABLE%%|$(LIBUNWIND_AVAILABLE)|' \ + -e 's|%%LIBUNWIND_LINK_FLAGS%%|$(LIBUNWIND_LINK_FLAGS)|' \ -e 's|%%MKDLL%%|$(MKDLL)|' \ -e 's|%%MKEXE%%|$(MKEXE)|' \ -e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \ -e 's|%%HOST%%|$(HOST)|' \ -e 's|%%TARGET%%|$(TARGET)|' \ -e 's|%%FLAMBDA%%|$(FLAMBDA)|' \ + -e 's|%%SAFE_STRING%%|$(SAFE_STRING)|' \ utils/config.mlp > utils/config.ml partialclean:: @@ -478,9 +496,11 @@ partialclean:: rm -f compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.a ocamlopt.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ + compilerlibs/ocamlbytecomp.cmxa \ $(OPTSTART:.cmo=.cmx) $(CAMLOPT) $(LINKFLAGS) -o ocamlopt.opt \ compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ + compilerlibs/ocamlbytecomp.cmxa \ $(OPTSTART:.cmo=.cmx) partialclean:: @@ -521,66 +541,32 @@ beforedepend:: bytecomp/runtimedef.ml # Choose the right machine-dependent files -asmcomp/arch.ml: asmcomp/$(ARCH)/arch.ml - ln -s $(ARCH)/arch.ml asmcomp/arch.ml - -partialclean:: - rm -f asmcomp/arch.ml - -beforedepend:: asmcomp/arch.ml - -asmcomp/proc.ml: asmcomp/$(ARCH)/proc.ml - ln -s $(ARCH)/proc.ml asmcomp/proc.ml - -partialclean:: - rm -f asmcomp/proc.ml - -beforedepend:: asmcomp/proc.ml - -asmcomp/selection.ml: asmcomp/$(ARCH)/selection.ml - ln -s $(ARCH)/selection.ml asmcomp/selection.ml - -partialclean:: - rm -f asmcomp/selection.ml - -beforedepend:: asmcomp/selection.ml - -asmcomp/CSE.ml: asmcomp/$(ARCH)/CSE.ml - ln -s $(ARCH)/CSE.ml asmcomp/CSE.ml - -partialclean:: - rm -f asmcomp/CSE.ml +asmcomp/arch.ml: asmcomp/$(ARCH_OCAMLOPT)/arch.ml + ln -s $(ARCH_OCAMLOPT)/arch.ml asmcomp/arch.ml -beforedepend:: asmcomp/CSE.ml +asmcomp/proc.ml: asmcomp/$(ARCH_OCAMLOPT)/proc.ml + ln -s $(ARCH_OCAMLOPT)/proc.ml asmcomp/proc.ml -asmcomp/reload.ml: asmcomp/$(ARCH)/reload.ml - ln -s $(ARCH)/reload.ml asmcomp/reload.ml +asmcomp/selection.ml: asmcomp/$(ARCH_OCAMLOPT)/selection.ml + ln -s $(ARCH_OCAMLOPT)/selection.ml asmcomp/selection.ml -partialclean:: - rm -f asmcomp/reload.ml +asmcomp/CSE.ml: asmcomp/$(ARCH_OCAMLOPT)/CSE.ml + ln -s $(ARCH_OCAMLOPT)/CSE.ml asmcomp/CSE.ml -beforedepend:: asmcomp/reload.ml +asmcomp/reload.ml: asmcomp/$(ARCH_OCAMLOPT)/reload.ml + ln -s $(ARCH_OCAMLOPT)/reload.ml asmcomp/reload.ml -asmcomp/scheduling.ml: asmcomp/$(ARCH)/scheduling.ml - ln -s $(ARCH)/scheduling.ml asmcomp/scheduling.ml - -partialclean:: - rm -f asmcomp/scheduling.ml - -beforedepend:: asmcomp/scheduling.ml +asmcomp/scheduling.ml: asmcomp/$(ARCH_OCAMLOPT)/scheduling.ml + ln -s $(ARCH_OCAMLOPT)/scheduling.ml asmcomp/scheduling.ml # Preprocess the code emitters -asmcomp/emit.ml: asmcomp/$(ARCH)/emit.mlp tools/cvt_emit - echo \# 1 \"$(ARCH)/emit.mlp\" > asmcomp/emit.ml - $(CAMLRUN) tools/cvt_emit >asmcomp/emit.ml \ +asmcomp/emit.ml: asmcomp/$(ARCH_OCAMLOPT)/emit.mlp tools/cvt_emit + echo \# 1 \"$(ARCH_OCAMLOPT)/emit.mlp\" > asmcomp/emit.ml + $(CAMLRUN) tools/cvt_emit >asmcomp/emit.ml \ || { rm -f asmcomp/emit.ml; exit 2; } -partialclean:: - rm -f asmcomp/emit.ml - -beforedepend:: asmcomp/emit.ml - tools/cvt_emit: tools/cvt_emit.mll cd tools && $(MAKE) cvt_emit @@ -764,6 +750,10 @@ depend: beforedepend middle_end/base_types driver toplevel; \ do $(CAMLDEP) $(DEPFLAGS) $$d/*.mli $$d/*.ml; \ done) > .depend + $(CAMLDEP) $(DEPFLAGS) -native \ + -impl driver/compdynlink.mlopt >> .depend + $(CAMLDEP) $(DEPFLAGS) -bytecode \ + -impl driver/compdynlink.mlbyte >> .depend alldepend:: depend diff --git a/Makefile.nt b/Makefile.nt index 079fca74..4207c996 100644 --- a/Makefile.nt +++ b/Makefile.nt @@ -115,7 +115,10 @@ coldstart: cp byterun/ocamlrun.exe boot/ocamlrun.exe cd yacc ; $(MAKEREC) $(BOOT_FLEXLINK_CMD) all cp yacc/ocamlyacc.exe boot/ocamlyacc.exe - cd stdlib ; $(MAKEREC) $(BOOT_FLEXLINK_CMD) COMPILER=../boot/ocamlc all + cd stdlib ; \ + $(MAKEREC) $(BOOT_FLEXLINK_CMD) \ + COMPILER="../boot/ocamlc -use-prims ../byterun/primitives"\ + all cd stdlib ; cp $(LIBFILES) ../boot # Build the core system: the minimum needed to make depend and bootstrap @@ -207,9 +210,11 @@ installbyt: cd byterun ; $(MAKEREC) install cp ocamlc "$(INSTALL_BINDIR)/ocamlc.exe" cp ocaml "$(INSTALL_BINDIR)/ocaml.exe" + cp ocamlc "$(INSTALL_BINDIR)/ocamlc.byte.exe" cd stdlib ; $(MAKEREC) install cp lex/ocamllex "$(INSTALL_BINDIR)/ocamllex.exe" cp yacc/ocamlyacc.exe "$(INSTALL_BINDIR)/ocamlyacc.exe" + cp lex/ocamllex "$(INSTALL_BINDIR)/ocamllex.byte.exe" cp utils/*.cmi utils/*.cmt utils/*.cmti \ parsing/*.cmi parsing/*.cmt parsing/*.cmti \ typing/*.cmi typing/*.cmt typing/*.cmti \ @@ -235,10 +240,12 @@ installbyt: $(MAKEREC) install-flexdll; \ 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" + if test -n "$(INSTALL_DISTRIB)"; then \ + 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"; \ + fi install-flexdll: # The $(if ...) installs the correct .manifest file for MSVC and MSVC64 @@ -254,6 +261,7 @@ install-flexdll: installopt: cd asmrun && $(MAKEREC) install cp ocamlopt "$(INSTALL_BINDIR)/ocamlopt.exe" + cp ocamlopt "$(INSTALL_BINDIR)/ocamlopt.byte.exe" cd stdlib && $(MAKEREC) installopt cp middle_end/*.cmi middle_end/*.cmt middle_end/*.cmti \ "$(INSTALL_COMPLIBDIR)" @@ -277,6 +285,9 @@ installoptopt: cp ocamlc.opt "$(INSTALL_BINDIR)/ocamlc.opt$(EXE)" cp ocamlopt.opt "$(INSTALL_BINDIR)/ocamlopt.opt$(EXE)" cp lex/ocamllex.opt "$(INSTALL_BINDIR)/ocamllex.opt$(EXE)" + cp ocamlc.opt "$(INSTALL_BINDIR)/ocamlc$(EXE)" + cp ocamlopt.opt "$(INSTALL_BINDIR)/ocamlopt$(EXE)" + cp lex/ocamllex.opt "$(INSTALL_BINDIR)/ocamllex$(EXE)" cp utils/*.cmx parsing/*.cmx typing/*.cmx bytecomp/*.cmx \ driver/*.cmx asmcomp/*.cmx "$(INSTALL_COMPLIBDIR)" cp compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.$(A) \ @@ -324,9 +335,11 @@ compilerlibs/ocamloptcomp.cma: $(MIDDLE_END) $(ASMCOMP) partialclean:: rm -f compilerlibs/ocamloptcomp.cma -ocamlopt: compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART) +ocamlopt: compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma \ + compilerlibs/ocamlbytecomp.cma $(OPTSTART) $(CAMLC) $(LINKFLAGS) -o ocamlopt \ - compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART) + compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma \ + compilerlibs/ocamlbytecomp.cma $(OPTSTART) partialclean:: rm -f ocamlopt @@ -351,9 +364,16 @@ partialclean:: # The native toplevel -ocamlnat: ocamlopt otherlibs/dynlink/dynlink.cmxa $(NATTOPOBJS:.cmo=.cmx) - $(CAMLOPT) $(LINKFLAGS) otherlibs/dynlink/dynlink.cmxa -o ocamlnat \ - $(NATTOPOBJS:.cmo=.cmx) -linkall +compilerlibs/ocamlopttoplevel.cmxa: $(OPTTOPLEVEL:.cmo=.cmx) + $(CAMLOPT) -a -o $@ $(OPTTOPLEVEL:.cmo=.cmx) +partialclean:: + rm -f compilerlibs/ocamlopttoplevel.cmxa + +ocamlnat: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ + compilerlibs/ocamlbytecomp.cmxa \ + compilerlibs/ocamlopttoplevel.cmxa \ + $(OPTTOPLEVELSTART:.cmo=.cmx) + $(CAMLOPT) $(LINKFLAGS) -linkall -o $@ $^ toplevel/opttoploop.cmx: otherlibs/dynlink/dynlink.cmxa @@ -389,6 +409,10 @@ utils/config.ml: utils/config.mlp config/Makefile -e 's|%%ASM%%|$(ASM)|' \ -e 's|%%ASM_CFI_SUPPORTED%%|false|' \ -e 's|%%WITH_FRAME_POINTERS%%|false|' \ + -e 's|%%WITH_SPACETIME%%|$(WITH_SPACETIME)|' \ + -e 's|%%PROFINFO_WIDTH%%|$(PROFINFO_WIDTH)|' \ + -e 's|%%LIBUNWIND_AVAILABLE%%|false|' \ + -e 's|%%LIBUNWIND_LINK_FLAGS%%||' \ -e 's|%%MKDLL%%|$(MKDLL)|' \ -e 's|%%MKEXE%%|$(MKEXE)|' \ -e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \ @@ -396,6 +420,7 @@ utils/config.ml: utils/config.mlp config/Makefile -e 's|%%HOST%%|$(HOST)|' \ -e 's|%%TARGET%%|$(TARGET)|' \ -e 's|%%FLAMBDA%%|$(FLAMBDA)|' \ + -e 's|%%SAFE_STRING%%|$(SAFE_STRING)|' \ -e 's|%%FLEXLINK_FLAGS%%|$(FLEXLINK_FLAGS)|' \ utils/config.mlp > utils/config.ml @@ -455,10 +480,12 @@ partialclean:: rm -f compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.$(A) ocamlopt.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ + compilerlibs/ocamlbytecomp.cmxa \ $(OPTSTART:.cmo=.cmx) $(CAMLOPT) $(LINKFLAGS) -o ocamlopt.opt \ - compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ - $(OPTSTART:.cmo=.cmx) + compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ + compilerlibs/ocamlbytecomp.cmxa \ + $(OPTSTART:.cmo=.cmx) partialclean:: rm -f ocamlopt.opt @@ -588,7 +615,7 @@ alldepend:: runtimeopt: makeruntimeopt stdlib/libasmrun.$(A) makeruntimeopt: - cd asmrun ; $(MAKEREC) all + cd asmrun ; $(MAKEREC) $(BOOT_FLEXLINK_CMD) all stdlib/libasmrun.$(A): asmrun/libasmrun.$(A) cp asmrun/libasmrun.$(A) stdlib/libasmrun.$(A) clean:: @@ -704,14 +731,20 @@ partialclean:: depend: beforedepend (for d in utils parsing typing bytecomp asmcomp middle_end \ middle_end/base_types driver toplevel; \ - do $(CAMLDEP) $(DEPFLAGS) $$d/*.mli $$d/*.ml; \ + do $(CAMLDEP) -slash $(DEPFLAGS) $$d/*.mli $$d/*.ml; \ done) > .depend + $(CAMLDEP) -slash $(DEPFLAGS) -native \ + -impl driver/compdynlink.mlopt >> .depend + $(CAMLDEP) -slash $(DEPFLAGS) -bytecode \ + -impl driver/compdynlink.mlbyte >> .depend alldepend:: depend distclean: $(MAKEREC) clean - rm -f asmrun/.depend.nt byterun/.depend.nt + rm -f asmrun/.depend.nt byterun/.depend.nt \ + otherlibs/bigarray/.depend.nt \ + otherlibs/str/.depend.nt rm -f boot/ocamlrun boot/ocamlrun.exe boot/camlheader boot/ocamlyacc \ boot/*.cm* boot/libcamlrun.a rm -f config/Makefile config/m.h config/s.h diff --git a/Makefile.shared b/Makefile.shared index f79b6322..5ffccb4a 100644 --- a/Makefile.shared +++ b/Makefile.shared @@ -17,19 +17,19 @@ defaultentry: # The main Makefile, fragments shared between Makefile and Makefile.nt - include config/Makefile CAMLRUN ?= boot/ocamlrun CAMLYACC ?= boot/ocamlyacc include stdlib/StdlibModules -CAMLC=$(CAMLRUN) boot/ocamlc -g -nostdlib -I boot +CAMLC=$(CAMLRUN) boot/ocamlc -g -nostdlib -I boot -use-prims byterun/primitives CAMLOPT=$(CAMLRUN) ./ocamlopt -g -nostdlib -I stdlib -I otherlibs/dynlink -COMPFLAGS=-strict-sequence -principal -w +33..39+48+50 -warn-error A \ +COMPFLAGS=-strict-sequence -principal -absname -w +a-4-9-41-42-44-45-48 \ + -warn-error A \ -bin-annot -safe-string -strict-formats $(INCLUDES) LINKFLAGS= -YACCFLAGS=-v +YACCFLAGS=-v --strict CAMLLEX=$(CAMLRUN) boot/ocamllex CAMLDEP=$(CAMLRUN) tools/ocamldep DEPFLAGS=$(INCLUDES) @@ -55,7 +55,7 @@ PARSING=parsing/location.cmo parsing/longident.cmo \ parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo \ parsing/pprintast.cmo \ parsing/ast_mapper.cmo parsing/ast_iterator.cmo parsing/attr_helper.cmo \ - parsing/builtin_attributes.cmo parsing/ast_invariants.cmo + parsing/builtin_attributes.cmo parsing/ast_invariants.cmo parsing/depend.cmo TYPING=typing/ident.cmo typing/path.cmo \ typing/primitive.cmo typing/types.cmo \ @@ -69,8 +69,8 @@ TYPING=typing/ident.cmo typing/path.cmo \ typing/tast_mapper.cmo \ typing/cmt_format.cmo typing/untypeast.cmo \ typing/includemod.cmo typing/typetexp.cmo typing/parmatch.cmo \ - typing/stypes.cmo typing/typecore.cmo \ - typing/typedecl.cmo typing/typeclass.cmo \ + typing/stypes.cmo typing/typedecl.cmo typing/typecore.cmo \ + typing/typeclass.cmo \ typing/typemod.cmo COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \ @@ -79,7 +79,6 @@ COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \ bytecomp/translcore.cmo \ bytecomp/translclass.cmo bytecomp/translmod.cmo \ bytecomp/simplif.cmo bytecomp/runtimedef.cmo \ - bytecomp/debuginfo.cmo \ driver/pparse.cmo driver/main_args.cmo \ driver/compenv.cmo driver/compmisc.cmo @@ -89,6 +88,7 @@ BYTECOMP=bytecomp/meta.cmo bytecomp/instruct.cmo bytecomp/bytegen.cmo \ bytecomp/printinstr.cmo bytecomp/opcodes.cmo bytecomp/emitcode.cmo \ bytecomp/bytesections.cmo bytecomp/dll.cmo bytecomp/symtable.cmo \ bytecomp/bytelink.cmo bytecomp/bytelibrarian.cmo bytecomp/bytepackager.cmo \ + driver/compdynlink.cmo driver/compplugin.cmo \ driver/errors.cmo driver/compile.cmo INTEL_ASM=\ @@ -121,7 +121,8 @@ ASMCOMP=\ asmcomp/import_approx.cmo \ asmcomp/un_anf.cmo \ asmcomp/strmatch.cmo asmcomp/cmmgen.cmo \ - asmcomp/printmach.cmo asmcomp/selectgen.cmo asmcomp/selection.cmo \ + asmcomp/printmach.cmo asmcomp/selectgen.cmo \ + asmcomp/spacetime_profiling.cmo asmcomp/selection.cmo \ asmcomp/comballoc.cmo \ asmcomp/CSEgen.cmo asmcomp/CSE.cmo \ asmcomp/liveness.cmo \ @@ -138,6 +139,7 @@ ASMCOMP=\ driver/opterrors.cmo driver/optcompile.cmo MIDDLE_END=\ + middle_end/debuginfo.cmo \ middle_end/base_types/tag.cmo \ middle_end/base_types/linkage_name.cmo \ middle_end/base_types/compilation_unit.cmo \ @@ -213,14 +215,17 @@ PERVASIVES=$(STDLIB_MODULES) outcometree topdirs toploop # The middle end (whose .cma library is currently only used for linking -# the "objinfo" program, since we cannot depend on the whole native code +# the "ocamlobjinfo" program, since we cannot depend on the whole native code # compiler for "make world" and the list of dependencies for # asmcomp/export_info.cmo is long). compilerlibs/ocamlmiddleend.cma: $(MIDDLE_END) $(CAMLC) -a -o $@ $(MIDDLE_END) +compilerlibs/ocamlmiddleend.cmxa: $(MIDDLE_END:%.cmo=%.cmx) + $(CAMLOPT) -a -o $@ $^ partialclean:: - rm -f compilerlibs/ocamlmiddleend.cma + rm -f compilerlibs/ocamlmiddleend.cma compilerlibs/ocamlmiddleend.cmxa \ + compilerlibs/ocamlmiddleend.$(A) # Tools @@ -228,17 +233,86 @@ partialclean:: ocamltools: ocamlc ocamlyacc ocamllex asmcomp/cmx_format.cmi \ asmcomp/printclambda.cmo compilerlibs/ocamlmiddleend.cma \ asmcomp/export_info.cmo - cd tools ; $(MAKEREC) all + +cd tools ; $(MAKEREC) all ocamltoolsopt: ocamlopt - cd tools; $(MAKEREC) opt + +cd tools; $(MAKEREC) opt -ocamltoolsopt.opt: ocamlc.opt ocamlyacc ocamllex asmcomp/cmx_format.cmi \ - asmcomp/printclambda.cmx - cd tools; $(MAKEREC) opt.opt +ocamltoolsopt.opt: ocamlc.opt ocamlyacc ocamllex.opt asmcomp/cmx_format.cmi \ + asmcomp/printclambda.cmx compilerlibs/ocamlmiddleend.cmxa \ + asmcomp/export_info.cmx + +cd tools; $(MAKEREC) opt.opt partialclean:: - cd tools; $(MAKEREC) clean + +cd tools; $(MAKEREC) clean alldepend:: - cd tools; $(MAKEREC) depend + +cd tools; $(MAKEREC) depend + +#config/Makefile: configure +# ./configure $(CONFIGURE_ARGS) + +## Test compilation of backend-specific parts + +ARCH_SPECIFIC = \ + asmcomp/arch.ml asmcomp/proc.ml asmcomp/CSE.ml asmcomp/selection.ml \ + asmcomp/scheduling.ml asmcomp/reload.ml asmcomp/scheduling.ml \ + asmcomp/emit.ml + +partialclean:: + rm -f $(ARCH_SPECIFIC) + +beforedepend:: $(ARCH_SPECIFIC) + +ARCH_OCAMLOPT:=$(ARCH) + +.PHONY: check_arch check_all_arches + +# This rule provides a quick way to check that machine-dependent +# files compiles fine for a foreign architecture (passed as ARCH=xxx). + +check_arch: + @echo "========= CHECKING asmcomp/$(ARCH) ==============" + @rm -f $(ARCH_SPECIFIC) asmcomp/*.cm* + @$(MAKEREC) ARCH_OCAMLOPT=$(ARCH) compilerlibs/ocamloptcomp.cma \ + >/dev/null + @rm -f $(ARCH_SPECIFIC) asmcomp/*.cm* + +ARCHES=amd64 i386 arm arm64 power sparc s390x + +check_all_arches: + @for i in $(ARCHES); do \ + $(MAKEREC) --no-print-directory check_arch ARCH=$$i; \ + done + +# Compiler Plugins + +DYNLINK_DIR=otherlibs/dynlink + +driver/compdynlink.mlbyte: $(DYNLINK_DIR)/dynlink.ml driver/compdynlink.mli + grep -v 'REMOVE_ME for ../../debugger/dynlink.ml' \ + $(DYNLINK_DIR)/dynlink.ml >driver/compdynlink.mlbyte + +ifeq ($(NATDYNLINK),true) +driver/compdynlink.mlopt: $(DYNLINK_DIR)/natdynlink.ml driver/compdynlink.mli + cp $(DYNLINK_DIR)/natdynlink.ml driver/compdynlink.mlopt +else +driver/compdynlink.mlopt: driver/compdynlink.mlno driver/compdynlink.mli + cp driver/compdynlink.mlno driver/compdynlink.mlopt +endif + +driver/compdynlink.mli: $(DYNLINK_DIR)/dynlink.mli + cp $(DYNLINK_DIR)/dynlink.mli driver/compdynlink.mli + +driver/compdynlink.cmo: driver/compdynlink.mlbyte driver/compdynlink.cmi + $(CAMLC) $(COMPFLAGS) -c -impl $< + +driver/compdynlink.cmx: driver/compdynlink.mlopt driver/compdynlink.cmi + $(CAMLOPT) $(COMPFLAGS) -c -impl $< + +beforedepend:: driver/compdynlink.mlbyte driver/compdynlink.mlopt \ + driver/compdynlink.mli +partialclean:: + rm -f driver/compdynlink.mlbyte + rm -f driver/compdynlink.mli + rm -f driver/compdynlink.mlopt diff --git a/Makefile.tools b/Makefile.tools new file mode 100644 index 00000000..9ec9a98d --- /dev/null +++ b/Makefile.tools @@ -0,0 +1,109 @@ +#************************************************************************** +#* * +#* OCaml * +#* * +#* Xavier Clerc, SED, INRIA Rocquencourt * +#* * +#* Copyright 2010 Institut National de Recherche en Informatique et * +#* en Automatique. * +#* * +#* All rights reserved. This file is distributed under the terms of * +#* the GNU Lesser General Public License version 2.1, with the * +#* special exception on linking described in the file LICENSE. * +#* * +#************************************************************************** + +# This makefile provides variables for using the in-tree compiler, +# interpreter, lexer and other associated tools. It is intended to be +# included within other makefiles. +# See testsuite/makefiles/Makefile.common, manual/tools/Makefile and +# manual/manual/tutorials/Makefile as examples. +# Note that these makefile should define the $(TOPDIR) variable on their +# own. + +WINTOPDIR=`cygpath -m "$(TOPDIR)"` + +# TOPDIR is the root directory of the OCaml sources, in Unix syntax. +# WINTOPDIR is the same directory, in Windows syntax. + +OTOPDIR=$(TOPDIR) +CTOPDIR=$(TOPDIR) +CYGPATH=echo +DIFF=diff -q +SORT=sort +SET_LD_PATH=CAML_LD_LIBRARY_PATH="$(LD_PATH)" + +# The variables above may be overridden by .../config/Makefile +# OTOPDIR is either TOPDIR or WINTOPDIR, whichever is appropriate for +# arguments given to the OCaml compiler. +# CTOPDIR is either TOPDIR or WINTOPDIR, whichever is appropriate for +# arguments given to the C and Fortran compilers. +# 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. +# 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 +# (CAML_LD_LIBRARY_PATH for Unix, PATH for Windows) using the LD_PATH shell +# variable. Note that for Windows we add Unix-syntax directory names in +# PATH, and Cygwin will translate it to Windows syntax. + +include $(TOPDIR)/config/Makefile + +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= + +ifeq ($(SUPPORTS_SHARED_LIBRARIES),false) + CUSTOM = -custom +else + CUSTOM = +endif + +OCAML=$(OCAMLRUN) $(OTOPDIR)/ocaml $(OCFLAGS) -noinit +EXPECT_TEST=$(OCAMLRUN) $(OTOPDIR)/testsuite/tools/expect_test$(EXE) +ifeq "$(FLEXLINK)" "" + FLEXLINK_PREFIX= +else + ifeq "$(wildcard $(TOPDIR)/flexdll/Makefile)" "" + FLEXLINK_PREFIX= + else + EMPTY= + FLEXLINK_PREFIX=OCAML_FLEXLINK="$(WINTOPDIR)/boot/ocamlrun \ + $(WINTOPDIR)/flexdll/flexlink.exe" $(EMPTY) + endif +endif +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=$(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) +DUMPOBJ=$(OCAMLRUN) $(OTOPDIR)/tools/dumpobj +OBJINFO=$(OCAMLRUN) $(OTOPDIR)/tools/ocamlobjinfo +BYTECODE_ONLY=[ "$(ARCH)" = "none" -o "$(ASM)" = "none" ] +NATIVECODE_ONLY=false + +#FORTRAN_COMPILER= +#FORTRAN_LIBRARY= + +UNIXLIBVAR=`case "$(OTHERLIBRARIES)" in *win32unix*) echo win32;; esac` diff --git a/README.adoc b/README.adoc index 73e477a8..480b0250 100644 --- a/README.adoc +++ b/README.adoc @@ -1,25 +1,24 @@ = README = -== OVERVIEW +== Overview OCaml is an implementation of the ML language, based on the Caml Light -dialect extended with a complete class-based object system and a -powerful module system in the style of Standard ML. +dialect extended with a complete class-based object system and a powerful +module system in the style of Standard ML. OCaml comprises two compilers. One generates bytecode which is then -interpreted by a C program. This compiler runs quickly, generates -compact code with moderate memory requirements, and is portable to -essentially any 32 or 64 bit Unix platform. Performance of generated -programs is quite good for a bytecoded implementation. This compiler -can be used either as a standalone, batch-oriented compiler that -produces standalone programs, or as an interactive, toplevel-based -system. - -The other compiler generates high-performance native code for a number -of processors. Compilation takes longer and generates bigger code, but -the generated programs deliver excellent performance, while retaining -the moderate memory requirements of the bytecode compiler. The -native-code compiler currently runs on the following platforms: +interpreted by a C program. This compiler runs quickly, generates compact +code with moderate memory requirements, and is portable to essentially any +32 or 64 bit Unix platform. Performance of generated programs is quite good +for a bytecoded implementation. This compiler can be used either as a +standalone, batch-oriented compiler that produces standalone programs, or as +an interactive, toplevel-based system. + +The other compiler generates high-performance native code for a number of +processors. Compilation takes longer and generates bigger code, but the +generated programs deliver excellent performance, while retaining the +moderate memory requirements of the bytecode compiler. The native-code +compiler currently runs on the following platforms: Tier 1 (actively used and maintained by the core OCaml team): @@ -36,79 +35,92 @@ PowerPC:: NetBSD ARM:: NetBSD SPARC:: Solaris, Linux, NetBSD -Other operating systems for the processors above have not been tested, -but the compiler may work under other operating systems with little work. +Other operating systems for the processors above have not been tested, but +the compiler may work under other operating systems with little work. -Before the introduction of objects, OCaml was known as Caml Special -Light. OCaml is almost upwards compatible with Caml Special Light, -except for a few additional reserved keywords that have forced some -renaming of standard library functions. +Before the introduction of objects, OCaml was known as Caml Special Light. +OCaml is almost upwards compatible with Caml Special Light, except for a few +additional reserved keywords that have forced some renaming of standard +library functions. -== CONTENTS +== Contents Changes:: what's new with each release + configure:: configure script + CONTRIBUTING.md:: how to contribute to OCaml INSTALL.adoc:: instructions for installation LICENSE:: license and copyright notice Makefile:: main Makefile + Makefile.nt:: MS Windows Makefile + Makefile.shared:: common Makefile + Makefile.tools:: used by manual/ and testsuite/ Makefiles README.adoc:: this file - README.win32.adoc:: infos on the MS Windows ports of OCaml + README.win32.adoc:: info on the MS Windows ports of OCaml + VERSION:: version string asmcomp/:: native-code compiler and linker asmrun/:: native-code runtime library boot/:: bootstrap compiler bytecomp/:: bytecode compiler and linker byterun/:: bytecode interpreter and runtime system + compilerlibs/:: the OCaml compiler as a library config/:: autoconfiguration stuff debugger/:: source-level replay debugger driver/:: driver code for the compilers emacs/:: editing mode and debugger interface for GNU Emacs + experimental/:: experiments not built by default + flexdll/:: empty (see README.win32.adoc) lex/:: lexer generator + man/:: man pages + manual/:: system to generate the manual + middle_end/:: the flambda optimisation phase ocamldoc/:: documentation generator otherlibs/:: several external libraries parsing/:: syntax analysis stdlib/:: standard library + testsuite/:: tests tools/:: various utilities toplevel/:: interactive system typing/:: typechecking utils/:: utility libraries yacc/:: parser generator -== COPYRIGHT +== Copyright -All files marked "Copyright INRIA" in this distribution are copyright -1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, -2007, 2008, 2009, 2010, 2011, 2012 Institut National de Recherche en -Informatique et en Automatique (INRIA) and distributed under the -conditions stated in file LICENSE. +All files marked "Copyright INRIA" in this distribution are copyright 1996, +1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, +2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 Institut National de +Recherche en Informatique et en Automatique (INRIA) and distributed under +the conditions stated in file LICENSE. -== INSTALLATION +== Installation -See the file INSTALL for installation instructions on machines running Unix, +See the file link:INSTALL.adoc[] for installation instructions on machines running Unix, Linux, OS X and Cygwin. For native Microsoft Windows, see link:README.win32.adoc[]. -== DOCUMENTATION +== Documentation -The OCaml manual is distributed in HTML, PDF, Postscript, DVI, and -Emacs Info files. It is available at +The OCaml manual is distributed in HTML, PDF, Postscript, DVI, and Emacs +Info files. It is available at http://caml.inria.fr/ The community also maintains the Web site http://ocaml.org, with tutorials -and other useful informations for OCaml users. +and other useful information for OCaml users. -== AVAILABILITY +== Availability The complete OCaml distribution can be accessed at http://caml.inria.fr/ -== KEEPING IN TOUCH WITH THE CAML COMMUNITY +== Keeping in Touch with the Caml Community -There exists a mailing list of users of the OCaml implementations -developed at INRIA. The purpose of this list is to share -experience, exchange ideas (and even code), and report on applications -of the OCaml language. Messages can be written in English or in -French. The list has more than 1000 subscribers. +There exists a mailing list of users of the OCaml implementations developed +at INRIA. The purpose of this list is to share experience, exchange ideas +(and even code), and report on applications of the OCaml language. Messages +can be written in English or in French. The list has more than 1000 +subscribers. Messages to the list should be sent to: @@ -120,20 +132,26 @@ https://sympa.inria.fr/sympa/subscribe/caml-list Archives of the list are available on the Web site above. -The Usenet news `groups comp.lang.ml` and `comp.lang.functional` -also contains discussions about the ML family of programming languages, -including OCaml. +The Usenet news `groups comp.lang.ml` and `comp.lang.functional` also +contains discussions about the ML family of programming languages, including +OCaml. The IRC channel `#ocaml` on https://freenode.net/[Freenode] also has several hundred users and welcomes questions. -== BUG REPORTS AND USER FEEDBACK +The OCaml Community website is -Please report bugs using the Web interface to the bug-tracking system -at http://caml.inria.fr/bin/caml-bugs +http://ocaml.org/ -To be effective, bug reports should include a complete program -(preferably small) that exhibits the unexpected behavior, and the -configuration you are using (machine type, etc). +== Bug Reports and User Feedback + +Please report bugs using the Web interface to the bug-tracking system at +http://caml.inria.fr/bin/caml-bugs + +To be effective, bug reports should include a complete program (preferably +small) that exhibits the unexpected behavior, and the configuration you are +using (machine type, etc). You can also contact the implementors directly at mailto:caml@inria.fr[]. + +For information on contributing to OCaml, see the file CONTRIBUTING.md. diff --git a/README.win32.adoc b/README.win32.adoc index f8b65eaf..9d5238cc 100644 --- a/README.win32.adoc +++ b/README.win32.adoc @@ -62,11 +62,13 @@ that a particular build is using the correct installation of `flexlink`. [[bmflex]] In addition to Cygwin, FlexDLL must also be installed, which is available from -http://alain.frisch.fr/flexdll.html. A binary distribution is available; +https://github.com/alainfrisch/flexdll. A binary distribution is available; instructions on how to build FlexDLL from sources, including how to bootstrap FlexDLL and OCaml are given <>. Unless you bootstrap FlexDLL, you will need to ensure that the directory to which you -install FlexDLL is included in your `PATH` environment variable. +install FlexDLL is included in your `PATH` environment variable. Note: if you +use Visual Studio 2015, the binary distribution of FlexDLL will not work and +you must build it from sources. The base bytecode system (ocamlc, ocaml, ocamllex, ocamlyacc, ...) of all three ports runs without any additional tools. @@ -103,6 +105,9 @@ Visual C/C++ Compiler. The command-line tools must be compiled from the Unix source distribution (`ocaml-X.YY.Z.tar.gz`), which also contains the files modified for Windows. +(Note: you should use cygwin's `tar` command to unpack this archive. If you +use WinZip, you will need to deselect "TAR file smart CR/LF conversion" in +the WinZip Options Window.) Microsoft Visual C/C++ is designed to be used from special developer mode Command Prompts which set the environment variables for the required compiler. @@ -244,6 +249,9 @@ package for 64-bit. The command-line tools must be compiled from the Unix source distribution (`ocaml-X.YY.Z.tar.gz`), which also contains the files modified for Windows. +(Note: you should use cygwin's `tar` command to unpack this archive. If you +use WinZip, you will need to deselect "TAR file smart CR/LF conversion" in +the WinZip Options Window.) Now run: @@ -293,11 +301,11 @@ may need to be careful to ensure that `ocamlopt` picks up the correct `flexlink` in your `PATH`. You must place the FlexDLL sources for Version 0.35 or later in the directory -`flexdll/` at the top-level directory of the directory of the OCaml -distribution. This can be done in one of three ways: +`flexdll/` at the top-level directory of the OCaml distribution. This can be +done in one of three ways: * Extracting the sources from a tarball from - http://alain.frisch.fr/flexdll.html#download + https://github.com/alainfrisch/flexdll/releases * Cloning the git repository by running: + git clone https://github.com/alainfrisch/flexdll.git diff --git a/VERSION b/VERSION index a376e21d..ed834ab2 100644 --- a/VERSION +++ b/VERSION @@ -1,4 +1,4 @@ -4.03.0 +4.04.0 # The version string is the first line of this file. # It must be in the format described in stdlib/sys.mli diff --git a/appveyor.yml b/appveyor.yml index ac0db2fb..7d4d8965 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -1,3 +1,17 @@ +#************************************************************************** +#* * +#* OCaml * +#* * +#* Christophe Troestler * +#* * +#* Copyright 2015 Christophe Troestler * +#* * +#* All rights reserved. This file is distributed under the terms of * +#* the GNU Lesser General Public License version 2.1, with the * +#* special exception on linking described in the file LICENSE. * +#* * +#************************************************************************** + # Compile the 64 bits version platform: - x64 diff --git a/appveyor_build.sh b/appveyor_build.sh index 7b95b046..b188fc2e 100644 --- a/appveyor_build.sh +++ b/appveyor_build.sh @@ -1,4 +1,17 @@ #!/bin/bash +#************************************************************************** +#* * +#* OCaml * +#* * +#* Christophe Troestler * +#* * +#* Copyright 2015 Christophe Troestler * +#* * +#* All rights reserved. This file is distributed under the terms of * +#* the GNU Lesser General Public License version 2.1, with the * +#* special exception on linking described in the file LICENSE. * +#* * +#************************************************************************** function run { NAME=$1 diff --git a/asmcomp/CSEgen.ml b/asmcomp/CSEgen.ml index 73bd903d..07b32f27 100644 --- a/asmcomp/CSEgen.ml +++ b/asmcomp/CSEgen.ml @@ -197,7 +197,7 @@ let remove_load_numbering n = let kill_addr_regs n = { n with num_reg = - Reg.Map.filter (fun r n -> r.Reg.typ <> Cmm.Addr) n.num_reg } + Reg.Map.filter (fun r _n -> r.Reg.typ <> Cmm.Addr) n.num_reg } (* Prepend a set of moves before [i] to assign [srcs] to [dsts]. *) @@ -207,7 +207,7 @@ let insert_move srcs dsts i = match Array.length srcs with | 0 -> i | 1 -> instr_cons (Iop Imove) srcs dsts i - | l -> (* Parallel move: first copy srcs into tmps one by one, + | _ -> (* Parallel move: first copy srcs into tmps one by one, then copy tmps into dsts one by one *) let tmps = Reg.createv_like srcs in let i1 = array_fold2 insert_single_move i tmps dsts in @@ -221,17 +221,16 @@ class cse_generic = object (self) method class_of_operation op = match op with | Imove | Ispill | Ireload -> assert false (* treated specially *) - | Iconst_int _ | Iconst_float _ | Iconst_symbol _ - | Iconst_blockheader _ -> Op_pure - | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iconst_int _ | Iconst_float _ | Iconst_symbol _ -> Op_pure + | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _ | Iextcall _ -> assert false (* treated specially *) | Istackoffset _ -> Op_other | Iload(_,_) -> Op_load | Istore(_,_,asg) -> Op_store asg | Ialloc _ -> assert false (* treated specially *) - | Iintop(Icheckbound) -> Op_checkbound + | Iintop(Icheckbound _) -> Op_checkbound | Iintop _ -> Op_pure - | Iintop_imm(Icheckbound, _) -> Op_checkbound + | Iintop_imm(Icheckbound _, _) -> Op_checkbound | Iintop_imm(_, _) -> Op_pure | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf | Ifloatofint | Iintoffloat -> Op_pure @@ -241,7 +240,7 @@ method class_of_operation op = method is_cheap_operation op = match op with - | Iconst_int _ | Iconst_blockheader _ -> true + | Iconst_int _ -> true | _ -> false (* Forget all equations involving memory loads. Performed after a @@ -255,7 +254,7 @@ method private kill_loads n = method private cse n i = match i.desc with - | Iend | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) + | Iend | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) | Iexit _ | Iraise _ -> i | Iop (Imove | Ispill | Ireload) -> @@ -263,7 +262,7 @@ method private cse n i = as to the argument reg. *) let n1 = set_move n i.arg.(0) i.res.(0) in {i with next = self#cse n1 i.next} - | Iop (Icall_ind | Icall_imm _ | Iextcall _) -> + | Iop (Icall_ind _ | Icall_imm _ | Iextcall _) -> (* For function calls, we should at least forget: - equations involving memory loads, since the callee can perform arbitrary memory stores; diff --git a/asmcomp/amd64/CSE.ml b/asmcomp/amd64/CSE.ml index d85e1629..10066e4b 100644 --- a/asmcomp/amd64/CSE.ml +++ b/asmcomp/amd64/CSE.ml @@ -19,7 +19,7 @@ open Arch open Mach open CSEgen -class cse = object (self) +class cse = object inherit cse_generic as super diff --git a/asmcomp/amd64/arch.ml b/asmcomp/amd64/arch.ml index a38e9ad5..451b431d 100644 --- a/asmcomp/amd64/arch.ml +++ b/asmcomp/amd64/arch.ml @@ -46,6 +46,8 @@ type specific_operation = and float_operation = Ifloatadd | Ifloatsub | Ifloatmul | Ifloatdiv +let spacetime_node_hole_pointer_is_live_before _specific_op = false + (* Sizes, endianness *) let big_endian = false @@ -73,11 +75,11 @@ let offset_addressing addr delta = | Iindexed2scaled(scale, n) -> Iindexed2scaled(scale, n + delta) let num_args_addressing = function - Ibased(s, n) -> 0 - | Iindexed n -> 1 - | Iindexed2 n -> 2 - | Iscaled(scale, n) -> 1 - | Iindexed2scaled(scale, n) -> 2 + Ibased _ -> 0 + | Iindexed _ -> 1 + | Iindexed2 _ -> 2 + | Iscaled _ -> 1 + | Iindexed2scaled _ -> 2 (* Printing operations and addressing modes *) diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index 6d058913..85b4cee3 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -168,11 +168,6 @@ let emit_label lbl = | S_macosx | S_win64 -> "L" ^ string_of_int lbl | _ -> ".L" ^ string_of_int lbl -let emit_data_label lbl = - match system with - | S_win64 -> "Ld" ^ string_of_int lbl - | _ -> ".Ld" ^ string_of_int lbl - let label s = sym (emit_label s) let def_label s = D.label (emit_label s) @@ -243,8 +238,12 @@ let addressing addr typ i n = (* Record live pointers at call points -- see Emitaux *) -let record_frame_label live dbg = - let lbl = new_label() in +let record_frame_label ?label live raise_ dbg = + let lbl = + match label with + | None -> new_label() + | Some label -> label + in let live_offset = ref [] in Reg.Set.iter (function @@ -261,45 +260,73 @@ let record_frame_label live dbg = { fd_lbl = lbl; fd_frame_size = frame_size(); fd_live_offset = !live_offset; + fd_raise = raise_; fd_debuginfo = dbg } :: !frame_descriptors; lbl -let record_frame live dbg = - let lbl = record_frame_label live dbg in +let record_frame ?label live raise_ dbg = + let lbl = record_frame_label ?label live raise_ dbg in def_label lbl +(* Spacetime instrumentation *) + +let spacetime_before_uninstrumented_call ~node_ptr ~index = + (* At the moment, [node_ptr] is pointing at the node for the current + OCaml function. Get hold of the node itself and move the pointer + forwards, saving it into the distinguished register. This is used + for instrumentation of function calls (e.g. caml_call_gc and bounds + check failures) not inserted until this stage of the compiler + pipeline. *) + I.mov node_ptr (reg Proc.loc_spacetime_node_hole); + assert (index >= 2); + I.add (int (index * 8)) (reg Proc.loc_spacetime_node_hole) + (* Record calls to the GC -- we've moved them out of the way *) type gc_call = { gc_lbl: label; (* Entry label *) gc_return_lbl: label; (* Where to branch after GC *) - gc_frame: label } (* Label of frame descriptor *) + gc_frame: label; (* Label of frame descriptor *) + gc_spacetime : (X86_ast.arg * int) option; + (* Spacetime node hole pointer and index *) + } let call_gc_sites = ref ([] : gc_call list) let emit_call_gc gc = def_label gc.gc_lbl; + begin match gc.gc_spacetime with + | None -> assert (not Config.spacetime) + | Some (node_ptr, index) -> + assert Config.spacetime; + spacetime_before_uninstrumented_call ~node_ptr ~index + end; emit_call "caml_call_gc"; def_label gc.gc_frame; I.jmp (label gc.gc_return_lbl) (* Record calls to caml_ml_array_bound_error. - In -g mode, we maintain one call to caml_ml_array_bound_error - per bound check site. Without -g, we can share a single call. *) + In -g mode, or when using Spacetime profiling, we maintain one call to + caml_ml_array_bound_error per bound check site. Without -g, we can share + a single call. *) type bound_error_call = { bd_lbl: label; (* Entry label *) - bd_frame: label } (* Label of frame descriptor *) + bd_frame: label; (* Label of frame descriptor *) + bd_spacetime : (X86_ast.arg * int) option; + (* As for [gc_call]. *) + } let bound_error_sites = ref ([] : bound_error_call list) let bound_error_call = ref 0 -let bound_error_label dbg = - if !Clflags.debug then begin +let bound_error_label ?label dbg ~spacetime = + if !Clflags.debug || Config.spacetime then begin let lbl_bound_error = new_label() in - let lbl_frame = record_frame_label Reg.Set.empty dbg in + let lbl_frame = record_frame_label ?label Reg.Set.empty false dbg in bound_error_sites := - { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites; + { bd_lbl = lbl_bound_error; bd_frame = lbl_frame; + bd_spacetime = spacetime; } :: !bound_error_sites; lbl_bound_error end else begin if !bound_error_call = 0 then bound_error_call := new_label(); @@ -308,6 +335,11 @@ let bound_error_label dbg = let emit_call_bound_error bd = def_label bd.bd_lbl; + begin match bd.bd_spacetime with + | None -> () + | Some (node_ptr, index) -> + spacetime_before_uninstrumented_call ~node_ptr ~index + end; emit_call "caml_ml_array_bound_error"; def_label bd.bd_frame @@ -463,7 +495,7 @@ let emit_instr fallthrough i = | Float, _, _ -> I.movsd (reg src) (reg dst) | _ -> I.mov (reg src) (reg dst) end - | Lop(Iconst_int n | Iconst_blockheader n) -> + | Lop(Iconst_int n) -> if n = 0n then begin match i.res.(0).loc with | Reg _ -> I.xor (res i 0) (res i 0) @@ -482,32 +514,40 @@ let emit_instr fallthrough i = | Lop(Iconst_symbol s) -> add_used_symbol s; load_symbol_addr s (res i 0) - | Lop(Icall_ind) -> + | Lop(Icall_ind { label_after; }) -> I.call (arg i 0); - record_frame i.live i.dbg - | Lop(Icall_imm s) -> - add_used_symbol s; - emit_call s; - record_frame i.live i.dbg - | Lop(Itailcall_ind) -> + record_frame i.live false i.dbg ~label:label_after + | Lop(Icall_imm { func; label_after; }) -> + add_used_symbol func; + emit_call func; + record_frame i.live false i.dbg ~label:label_after + | Lop(Itailcall_ind { label_after; }) -> output_epilogue begin fun () -> - I.jmp (arg i 0) + I.jmp (arg i 0); + if Config.spacetime then begin + record_frame Reg.Set.empty false i.dbg ~label:label_after + end end - | Lop(Itailcall_imm s) -> - if s = !function_name then - I.jmp (label !tailrec_entry_point) - else begin - output_epilogue begin fun () -> - add_used_symbol s; - emit_jump s + | Lop(Itailcall_imm { func; label_after; }) -> + begin + if func = !function_name then + I.jmp (label !tailrec_entry_point) + else begin + output_epilogue begin fun () -> + add_used_symbol func; + emit_jump func + end end + end; + if Config.spacetime then begin + record_frame Reg.Set.empty false i.dbg ~label:label_after end - | Lop(Iextcall(s, alloc)) -> - add_used_symbol s; + | Lop(Iextcall { func; alloc; label_after; }) -> + add_used_symbol func; if alloc then begin - load_symbol_addr s rax; + load_symbol_addr func rax; emit_call "caml_c_call"; - record_frame i.live i.dbg; + record_frame i.live false i.dbg ~label:label_after; if system <> S_win64 then begin (* TODO: investigate why such a diff. This comes from: @@ -518,9 +558,13 @@ let emit_instr fallthrough i = *) load_symbol_addr "caml_young_ptr" r11; I.mov (mem64 QWORD 0 R11) r15 - end; - end else - emit_call s + end + end else begin + emit_call func; + if Config.spacetime then begin + record_frame Reg.Set.empty false i.dbg ~label:label_after + end + end | Lop(Istackoffset n) -> if n < 0 then I.add (int (-n)) rsp @@ -567,25 +611,53 @@ let emit_instr fallthrough i = | Double | Double_u -> I.movsd (arg i 0) (addressing addr REAL8 i 1) end - | Lop(Ialloc n) -> + | Lop(Ialloc { words = n; label_after_call_gc; spacetime_index; }) -> if !fastcode_flag then begin let lbl_redo = new_label() in def_label lbl_redo; I.sub (int n) r15; + let spacetime_node_hole_ptr_is_in_rax = + Config.spacetime && (i.arg.(0).loc = Reg 0) + in if !Clflags.dlcode then begin + (* When using Spacetime, %rax might be the node pointer, so we + must take care not to clobber it. (Whilst we can tell the + register allocator that %rax is destroyed by Ialloc, we can't + force that the argument (the node pointer) is not in %rax.) *) + if spacetime_node_hole_ptr_is_in_rax then begin + I.push rax + end; load_symbol_addr "caml_young_limit" rax; I.cmp (mem64 QWORD 0 RAX) r15; + if spacetime_node_hole_ptr_is_in_rax then begin + I.pop rax (* this does not affect the flags *) + end end else I.cmp (mem64_rip QWORD (emit_symbol "caml_young_limit")) r15; let lbl_call_gc = new_label() in - let lbl_frame = record_frame_label i.live Debuginfo.none in + let dbg = + if not Config.spacetime then Debuginfo.none + else i.dbg + in + let lbl_frame = + record_frame_label ?label:label_after_call_gc i.live false dbg + in I.jb (label lbl_call_gc); I.lea (mem64 NONE 8 R15) (res i 0); + let gc_spacetime = + if not Config.spacetime then None + else Some (arg i 0, spacetime_index) + in call_gc_sites := { gc_lbl = lbl_call_gc; gc_return_lbl = lbl_redo; - gc_frame = lbl_frame } :: !call_gc_sites + gc_frame = lbl_frame; + gc_spacetime; } :: !call_gc_sites end else begin + if Config.spacetime then begin + spacetime_before_uninstrumented_call ~node_ptr:(arg i 0) + ~index:spacetime_index; + end; begin match n with | 16 -> emit_call "caml_alloc1" | 24 -> emit_call "caml_alloc2" @@ -594,7 +666,11 @@ let emit_instr fallthrough i = I.mov (int n) rax; emit_call "caml_allocN" end; - record_frame i.live Debuginfo.none; + let label = + record_frame_label ?label:label_after_call_gc i.live false + Debuginfo.none + in + def_label label; I.lea (mem64 NONE 8 R15) (res i 0) end | Lop(Iintop(Icomp cmp)) -> @@ -605,12 +681,20 @@ let emit_instr fallthrough i = I.cmp (int n) (arg i 0); I.set (cond cmp) al; I.movzx al (res i 0) - | Lop(Iintop Icheckbound) -> - let lbl = bound_error_label i.dbg in + | Lop(Iintop (Icheckbound { label_after_error; spacetime_index; } )) -> + let spacetime = + if not Config.spacetime then None + else Some (arg i 2, spacetime_index) + in + let lbl = bound_error_label ?label:label_after_error i.dbg ~spacetime in I.cmp (arg i 1) (arg i 0); I.jbe (label lbl) - | Lop(Iintop_imm(Icheckbound, n)) -> - let lbl = bound_error_label i.dbg in + | Lop(Iintop_imm(Icheckbound { label_after_error; spacetime_index; }, n)) -> + let spacetime = + if not Config.spacetime then None + else Some (arg i 1, spacetime_index) + in + let lbl = bound_error_label ?label:label_after_error i.dbg ~spacetime in I.cmp (int n) (arg i 0); I.jbe (label lbl) | Lop(Iintop(Idiv | Imod)) -> @@ -766,15 +850,14 @@ let emit_instr fallthrough i = cfi_adjust_cfa_offset (-8); stack_offset := !stack_offset - 16 | Lraise k -> - begin match !Clflags.debug, k with - | true, Lambda.Raise_regular -> + (* No Spacetime instrumentation is required for [caml_raise_exn] and + [caml_reraise_exn]. The only function called that might affect the + trie is [caml_stash_backtrace], and it does not. *) + begin match k with + | Cmm.Raise_withtrace -> emit_call "caml_raise_exn"; - record_frame Reg.Set.empty i.dbg - | true, Lambda.Raise_reraise -> - emit_call "caml_reraise_exn"; - record_frame Reg.Set.empty i.dbg - | false, _ - | true, Lambda.Raise_notrace -> + record_frame Reg.Set.empty true i.dbg + | Cmm.Raise_notrace -> I.mov r14 rsp; I.pop r14; I.ret () @@ -798,10 +881,14 @@ let emit_profile () = like mcount expects it, though. *) I.push r10; if not fp then I.mov rsp rbp; + (* No Spacetime instrumentation needed: [mcount] cannot call anything + OCaml-related. *) emit_call "mcount"; I.pop r10 end +let all_functions = ref [] + (* Emission of a function declaration *) let fundecl fundecl = @@ -812,6 +899,7 @@ let fundecl fundecl = call_gc_sites := []; bound_error_sites := []; bound_error_call := 0; + all_functions := fundecl :: !all_functions; D.text (); D.align 16; add_def_symbol fundecl.fun_name; @@ -866,7 +954,6 @@ let fundecl fundecl = let emit_item = function | Cglobal_symbol s -> D.global (emit_symbol s) | Cdefine_symbol s -> add_def_symbol s; _label (emit_symbol s) - | Cdefine_label lbl -> _label (emit_data_label lbl) | Cint8 n -> D.byte (const n) | Cint16 n -> D.word (const n) | Cint32 n -> D.long (const_nat n) @@ -874,7 +961,6 @@ let emit_item = function | Csingle f -> D.long (Const (Int64.of_int32 (Int32.bits_of_float f))) | Cdouble f -> D.qword (Const (Int64.bits_of_float f)) | Csymbol_address s -> add_used_symbol s; D.qword (ConstLabel (emit_symbol s)) - | Clabel_address lbl -> D.qword (ConstLabel (emit_data_label lbl)) | Cstring s -> D.bytes s | Cskip n -> if n > 0 then D.space n | Calign n -> D.align n @@ -890,6 +976,7 @@ let begin_assembly() = reset_debug_info(); (* PR#5603 *) reset_imp_table(); float_constants := []; + all_functions := []; if system = S_win64 then begin D.extrn "caml_young_ptr" QWORD; D.extrn "caml_young_limit" QWORD; @@ -902,7 +989,6 @@ let begin_assembly() = D.extrn "caml_alloc3" NEAR; D.extrn "caml_ml_array_bound_error" NEAR; D.extrn "caml_raise_exn" NEAR; - D.extrn "caml_reraise_exn" NEAR; end; @@ -932,6 +1018,40 @@ let begin_assembly() = if system = S_macosx then I.nop (); (* PR#4690 *) () +let emit_spacetime_shapes () = + D.data (); + D.align 8; + emit_global_label "spacetime_shapes"; + List.iter (fun fundecl -> + (* CR-someday mshinwell: some of this should be platform independent *) + begin match fundecl.fun_spacetime_shape with + | None -> () + | Some shape -> + let funsym = emit_symbol fundecl.fun_name in + D.comment ("Shape for " ^ funsym ^ ":"); + D.qword (ConstLabel funsym); + List.iter (fun (part_of_shape, label) -> + let tag = + match part_of_shape with + | Direct_call_point _ -> 1 + | Indirect_call_point -> 2 + | Allocation_point -> 3 + in + D.qword (Const (Int64.of_int tag)); + D.qword (ConstLabel (emit_label label)); + begin match part_of_shape with + | Direct_call_point { callee; } -> + D.qword (ConstLabel (emit_symbol callee)) + | Indirect_call_point -> () + | Allocation_point -> () + end) + shape; + D.qword (Const 0L) + end) + !all_functions; + D.qword (Const 0L); + D.comment "End of Spacetime shapes." + let end_assembly() = if !float_constants <> [] then begin begin match system with @@ -959,7 +1079,8 @@ let end_assembly() = let setcnt = ref 0 in emit_frames - { efa_label = (fun l -> D.qword (ConstLabel (emit_label l))); + { efa_code_label = (fun l -> D.qword (ConstLabel (emit_label l))); + efa_data_label = (fun l -> D.qword (ConstLabel (emit_label l))); efa_16 = (fun n -> D.word (const n)); efa_32 = (fun n -> D.long (const_32 n)); efa_word = (fun n -> D.qword (const n)); @@ -983,6 +1104,10 @@ let end_assembly() = efa_string = (fun s -> D.bytes (s ^ "\000")) }; + if Config.spacetime then begin + emit_spacetime_shapes () + end; + if system = S_linux then (* Mark stack as non-executable, PR#4564 *) D.section [".note.GNU-stack"] (Some "") [ "%progbits" ]; diff --git a/asmcomp/amd64/proc.ml b/asmcomp/amd64/proc.ml index 3f18d50d..92f68b50 100644 --- a/asmcomp/amd64/proc.ml +++ b/asmcomp/amd64/proc.ml @@ -31,13 +31,6 @@ let win64 = | "win64" | "mingw64" | "cygwin" -> true | _ -> false -(* Which asm conventions to use *) - -let masm = - match Config.ccomp_type with - | "msvc" -> true - | _ -> false - (* Registers available for register allocation *) (* Register map: @@ -138,8 +131,8 @@ let phys_reg n = if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) let rax = phys_reg 0 -let rcx = phys_reg 5 let rdx = phys_reg 4 +let r13 = phys_reg 9 let rbp = phys_reg 12 let rxmm15 = phys_reg 115 @@ -181,14 +174,22 @@ let calling_conventions first_int last_int first_float last_float make_stack let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs -let not_supported ofs = fatal_error "Proc.loc_results: cannot call" +let not_supported _ofs = fatal_error "Proc.loc_results: cannot call" + +let max_int_args_in_regs () = + if Config.spacetime then 9 else 10 let loc_arguments arg = - calling_conventions 0 9 100 109 outgoing arg + calling_conventions 0 ((max_int_args_in_regs ()) - 1) 100 109 outgoing arg let loc_parameters arg = - let (loc, ofs) = calling_conventions 0 9 100 109 incoming arg in loc + let (loc, _ofs) = + calling_conventions 0 ((max_int_args_in_regs ()) - 1) 100 109 incoming arg + in + loc let loc_results res = - let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc + let (loc, _ofs) = calling_conventions 0 0 100 100 not_supported res in loc + +let loc_spacetime_node_hole = r13 (* C calling conventions under Unix: first integer args in rdi, rsi, rdx, rcx, r8, r9 @@ -204,7 +205,7 @@ let loc_results res = Return value in rax or xmm0. *) let loc_external_results res = - let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc + let (loc, _ofs) = calling_conventions 0 0 100 100 not_supported res in loc let unix_loc_external_arguments arg = calling_conventions 2 7 100 107 outgoing arg @@ -253,7 +254,7 @@ let loc_exn_bucket = rax (* Volatile registers: none *) -let regs_are_volatile rs = false +let regs_are_volatile _rs = false (* Registers destroyed by operations *) @@ -271,13 +272,20 @@ let destroyed_at_c_call = 108;109;110;111;112;113;114;115]) let destroyed_at_oper = function - Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs - | Iop(Iextcall(_, false)) -> destroyed_at_c_call + Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; }) -> + all_phys_regs + | Iop(Iextcall { alloc = false; }) -> destroyed_at_c_call | Iop(Iintop(Idiv | Imod)) | Iop(Iintop_imm((Idiv | Imod), _)) -> [| rax; rdx |] | Iop(Istore(Single, _, _)) -> [| rxmm15 |] + | Iop(Ialloc _) when Config.spacetime + -> [| rax; loc_spacetime_node_hole |] | Iop(Ialloc _ | Iintop(Imulh | Icomp _) | Iintop_imm((Icomp _), _)) -> [| rax |] + | Iop (Iintop (Icheckbound _)) when Config.spacetime -> + [| loc_spacetime_node_hole |] + | Iop (Iintop_imm(Icheckbound _, _)) when Config.spacetime -> + [| loc_spacetime_node_hole |] | Iswitch(_, _) -> [| rax; rdx |] | _ -> if fp then @@ -293,11 +301,11 @@ let destroyed_at_raise = all_phys_regs let safe_register_pressure = function - Iextcall(_,_) -> if win64 then if fp then 7 else 8 else 0 + Iextcall _ -> if win64 then if fp then 7 else 8 else 0 | _ -> if fp then 10 else 11 let max_register_pressure = function - Iextcall(_, _) -> + Iextcall _ -> if win64 then if fp then [| 7; 10 |] else [| 8; 10 |] else @@ -314,9 +322,9 @@ let max_register_pressure = function registers). *) let op_is_pure = function - | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _ | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ - | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> false + | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _) -> false | Ispecific(Ilea _) -> true | Ispecific _ -> false | _ -> true diff --git a/asmcomp/amd64/reload.ml b/asmcomp/amd64/reload.ml index 9ea80d06..2e29de4c 100644 --- a/asmcomp/amd64/reload.ml +++ b/asmcomp/amd64/reload.ml @@ -24,8 +24,7 @@ open Mach Operation Res Arg1 Arg2 Imove R S or S R - Iconst_int ] S if 32-bit signed, R otherwise - Iconst_blockheader ] + Iconst_int S if 32-bit signed, R otherwise Iconst_float R Iconst_symbol (not PIC) S Iconst_symbol (PIC) R @@ -66,7 +65,7 @@ inherit Reloadgen.reload_generic as super method! reload_operation op arg res = match op with - | Iintop(Iadd|Isub|Iand|Ior|Ixor|Icomp _|Icheckbound) -> + | Iintop(Iadd|Isub|Iand|Ior|Ixor|Icomp _|Icheckbound _) -> (* One of the two arguments can reside in the stack, but not both *) if stackp arg.(0) && stackp arg.(1) then ([|arg.(0); self#makereg arg.(1)|], res) @@ -90,7 +89,7 @@ method! reload_operation op arg res = | Ifloatofint | Iintoffloat -> (* Result must be in register, but argument can be on stack *) (arg, (if stackp res.(0) then [| self#makereg res.(0) |] else res)) - | Iconst_int n | Iconst_blockheader n -> + | Iconst_int n -> if n <= 0x7FFFFFFFn && n >= -0x80000000n then (arg, res) else super#reload_operation op arg res @@ -103,7 +102,7 @@ method! reload_operation op arg res = method! reload_test tst arg = match tst with - Iinttest cmp -> + Iinttest _ -> (* One of the two arguments can reside on stack *) if stackp arg.(0) && stackp arg.(1) then [| self#makereg arg.(0); arg.(1) |] diff --git a/asmcomp/amd64/selection.ml b/asmcomp/amd64/selection.ml index 3c1a344e..fb50bc15 100644 --- a/asmcomp/amd64/selection.ml +++ b/asmcomp/amd64/selection.ml @@ -123,25 +123,27 @@ let inline_ops = class selector = object (self) -inherit Selectgen.selector_generic as super +inherit Spacetime_profiling.instruction_selection as super -method is_immediate n = n <= 0x7FFFFFFF && n >= -0x80000000 +method is_immediate n = n <= 0x7FFF_FFFF && n >= (-1-0x7FFF_FFFF) + (* -1-.... : hack so that this can be compiled on 32-bit + (cf 'make check_all_arches') *) method is_immediate_natint n = n <= 0x7FFFFFFFn && n >= -0x80000000n method! is_simple_expr e = match e with - | Cop(Cextcall(fn, _, _, _), args) + | Cop(Cextcall (fn, _, _, _, _), args) when List.mem fn inline_ops -> (* inlined ops are simple if their arguments are *) List.for_all self#is_simple_expr args | _ -> super#is_simple_expr e -method select_addressing chunk exp = +method select_addressing _chunk exp = let (a, d) = select_addr exp in (* PR#4625: displacement must be a signed 32-bit immediate *) - if d < -0x8000_0000 || d > 0x7FFF_FFFF + if not (self # is_immediate d) then (Iindexed 0, exp) else match a with | Asymbol s -> @@ -159,7 +161,10 @@ method! select_store is_assign addr exp = match exp with Cconst_int n when self#is_immediate n -> (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple []) - | (Cconst_natint n | Cconst_blockheader n) when self#is_immediate_natint n -> + | (Cconst_natint n) when self#is_immediate_natint n -> + (Ispecific(Istore_int(n, addr, is_assign)), Ctuple []) + | (Cblockheader(n, _dbg)) + when self#is_immediate_natint n && not Config.spacetime -> (Ispecific(Istore_int(n, addr, is_assign)), Ctuple []) | Cconst_pointer n when self#is_immediate n -> (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple []) @@ -175,7 +180,7 @@ method! select_operation op args = (* Recognize the LEA instruction *) Caddi | Caddv | Cadda | Csubi -> begin match self#select_addressing Word_int (Cop(op, args)) with - (Iindexed d, _) -> super#select_operation op args + (Iindexed _, _) | (Iindexed2 0, _) -> super#select_operation op args | (addr, arg) -> (Ispecific(Ilea addr), [arg]) end @@ -188,7 +193,7 @@ method! select_operation op args = self#select_floatarith true Imulf Ifloatmul args | Cdivf -> self#select_floatarith false Idivf Ifloatdiv args - | Cextcall("sqrt", _, false, _) -> + | Cextcall("sqrt", _, false, _, _) -> begin match args with [Cop(Cload (Double|Double_u as chunk), [loc])] -> let (addr, arg) = self#select_addressing chunk loc in @@ -208,12 +213,12 @@ method! select_operation op args = | _ -> super#select_operation op args end - | Cextcall("caml_bswap16_direct", _, _, _) -> + | Cextcall("caml_bswap16_direct", _, _, _, _) -> (Ispecific (Ibswap 16), args) - | Cextcall("caml_int32_direct_bswap", _, _, _) -> + | Cextcall("caml_int32_direct_bswap", _, _, _, _) -> (Ispecific (Ibswap 32), args) - | Cextcall("caml_int64_direct_bswap", _, _, _) - | Cextcall("caml_nativeint_direct_bswap", _, _, _) -> + | Cextcall("caml_int64_direct_bswap", _, _, _, _) + | Cextcall("caml_nativeint_direct_bswap", _, _, _, _) -> (Ispecific (Ibswap 64), args) (* AMD64 does not support immediate operands for multiply high signed *) | Cmulhi -> diff --git a/asmcomp/arm/CSE.ml b/asmcomp/arm/CSE.ml index 3ab5a35d..2269cbec 100644 --- a/asmcomp/arm/CSE.ml +++ b/asmcomp/arm/CSE.ml @@ -19,7 +19,7 @@ open Arch open Mach open CSEgen -class cse = object (self) +class cse = object inherit cse_generic as super @@ -31,7 +31,7 @@ method! class_of_operation op = method! is_cheap_operation op = match op with - | Iconst_int n | Iconst_blockheader n -> n <= 255n && n >= 0n + | Iconst_int n -> n <= 255n && n >= 0n | _ -> false end diff --git a/asmcomp/arm/arch.ml b/asmcomp/arm/arch.ml index 72f88a05..0bee7e1e 100644 --- a/asmcomp/arm/arch.ml +++ b/asmcomp/arm/arch.ml @@ -137,6 +137,8 @@ and shift_operation = | Ishiftlogicalright | Ishiftarithmeticright +let spacetime_node_hole_pointer_is_live_before _specific_op = false + (* Sizes, endianness *) let big_endian = false @@ -157,7 +159,7 @@ let identity_addressing = Iindexed 0 let offset_addressing (Iindexed n) delta = Iindexed(n + delta) -let num_args_addressing (Iindexed n) = 1 +let num_args_addressing (Iindexed _) = 1 (* Printing operations and addressing modes *) diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp index a63f9e8b..de61da57 100644 --- a/asmcomp/arm/emit.mlp +++ b/asmcomp/arm/emit.mlp @@ -1,3 +1,4 @@ +#2 "asmcomp/arm/emit.mlp" (**************************************************************************) (* *) (* OCaml *) @@ -34,9 +35,6 @@ let fastcode_flag = ref true let emit_label lbl = emit_string ".L"; emit_int lbl -let emit_data_label lbl = - emit_string ".Ld"; emit_int lbl - (* Symbols *) let emit_symbol s = @@ -101,8 +99,12 @@ let emit_addressing addr r n = (* Record live pointers at call points *) -let record_frame_label live dbg = - let lbl = new_label() in +let record_frame_label ?label live raise_ dbg = + let lbl = + match label with + | None -> new_label() + | Some label -> label + in let live_offset = ref [] in Reg.Set.iter (function @@ -118,11 +120,12 @@ let record_frame_label live dbg = { fd_lbl = lbl; fd_frame_size = frame_size(); fd_live_offset = !live_offset; + fd_raise = raise_; fd_debuginfo = dbg } :: !frame_descriptors; lbl -let record_frame live dbg = - let lbl = record_frame_label live dbg in `{emit_label lbl}:` +let record_frame ?label live raise_ dbg = + let lbl = record_frame_label ?label live raise_ dbg in `{emit_label lbl}:` (* Record calls to the GC -- we've moved them out of the way *) @@ -147,10 +150,10 @@ type bound_error_call = let bound_error_sites = ref ([] : bound_error_call list) -let bound_error_label dbg = +let bound_error_label ?label dbg = if !Clflags.debug || !bound_error_sites = [] then begin let lbl_bound_error = new_label() in - let lbl_frame = record_frame_label Reg.Set.empty dbg in + let lbl_frame = record_frame_label ?label Reg.Set.empty false dbg in bound_error_sites := { bd_lbl = lbl_bound_error; bd_frame_lbl = lbl_frame } :: !bound_error_sites; @@ -392,7 +395,7 @@ let emit_instr i = ` ldr {emit_reg dst}, {emit_stack src}\n` end; 1 end - | Lop(Iconst_int n | Iconst_blockheader n) -> + | Lop(Iconst_int n) -> emit_intconst i.res.(0) (Nativeint.to_int32 n) | Lop(Iconst_float f) when !fpu = Soft -> let high_bits = Int64.to_int32 (Int64.shift_right_logical f 32) @@ -437,40 +440,40 @@ let emit_instr i = end; 1 | Lop(Iconst_symbol s) -> emit_load_symbol_addr i.res.(0) s - | Lop(Icall_ind) -> + | Lop(Icall_ind { label_after; }) -> if !arch >= ARMv5 then begin ` blx {emit_reg i.arg.(0)}\n`; - `{record_frame i.live i.dbg}\n`; 1 + `{record_frame i.live false i.dbg ~label:label_after}\n`; 1 end else begin ` mov lr, pc\n`; ` bx {emit_reg i.arg.(0)}\n`; - `{record_frame i.live i.dbg}\n`; 2 + `{record_frame i.live false i.dbg ~label:label_after}\n`; 2 end - | Lop(Icall_imm s) -> - ` {emit_call s}\n`; - `{record_frame i.live i.dbg}\n`; 1 - | Lop(Itailcall_ind) -> + | Lop(Icall_imm { func; label_after; }) -> + ` {emit_call func}\n`; + `{record_frame i.live false i.dbg ~label:label_after}\n`; 1 + | Lop(Itailcall_ind { label_after = _; }) -> output_epilogue begin fun () -> if !contains_calls then ` ldr lr, [sp, #{emit_int (-4)}]\n`; ` bx {emit_reg i.arg.(0)}\n`; 2 end - | Lop(Itailcall_imm s) -> - if s = !function_name then begin + | Lop(Itailcall_imm { func; label_after = _; }) -> + if func = !function_name then begin ` b {emit_label !tailrec_entry_point}\n`; 1 end else begin output_epilogue begin fun () -> if !contains_calls then ` ldr lr, [sp, #{emit_int (-4)}]\n`; - ` {emit_jump s}\n`; 2 + ` {emit_jump func}\n`; 2 end end - | Lop(Iextcall(s, false)) -> - ` {emit_call s}\n`; 1 - | Lop(Iextcall(s, true)) -> - let ninstr = emit_load_symbol_addr (phys_reg 7 (* r7 *)) s in + | Lop(Iextcall { func; alloc = false; }) -> + ` {emit_call func}\n`; 1 + | Lop(Iextcall { func; alloc = true; label_after; }) -> + let ninstr = emit_load_symbol_addr (phys_reg 7 (* r7 *)) func in ` {emit_call "caml_c_call"}\n`; - `{record_frame i.live i.dbg}\n`; + `{record_frame i.live false i.dbg ~label:label_after}\n`; 1 + ninstr | Lop(Istackoffset n) -> assert (n mod 8 = 0); @@ -540,8 +543,10 @@ let emit_instr i = | Double_u -> "fstd" | _ (* 32-bit quantities *) -> "str" in ` {emit_string instr} {emit_reg r}, {emit_addressing addr i.arg 1}\n`; 1 - | Lop(Ialloc n) -> - let lbl_frame = record_frame_label i.live i.dbg in + | Lop(Ialloc { words = n; label_after_call_gc; }) -> + let lbl_frame = + record_frame_label i.live false i.dbg ?label:label_after_call_gc + in if !fastcode_flag then begin let lbl_redo = new_label() in `{emit_label lbl_redo}:`; @@ -584,12 +589,12 @@ let emit_instr i = ` ite {emit_string compthen}\n`; ` mov{emit_string compthen} {emit_reg i.res.(0)}, #1\n`; ` mov{emit_string compelse} {emit_reg i.res.(0)}, #0\n`; 4 - | Lop(Iintop Icheckbound) -> - let lbl = bound_error_label i.dbg in + | Lop(Iintop (Icheckbound { label_after_error; } )) -> + let lbl = bound_error_label ?label:label_after_error i.dbg in ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; ` bls {emit_label lbl}\n`; 2 - | Lop(Iintop_imm(Icheckbound, n)) -> - let lbl = bound_error_label i.dbg in + | Lop(Iintop_imm(Icheckbound { label_after_error; }, n)) -> + let lbl = bound_error_label ?label:label_after_error i.dbg in ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; ` bls {emit_label lbl}\n`; 2 | Lop(Ispecific(Ishiftcheckbound(shiftop, n))) -> @@ -786,12 +791,11 @@ let emit_instr i = cfi_adjust_cfa_offset (-8); stack_offset := !stack_offset - 8; 1 | Lraise k -> - begin match !Clflags.debug, k with - | true, (Lambda.Raise_regular | Lambda.Raise_reraise) -> + begin match k with + | Cmm.Raise_withtrace -> ` {emit_call "caml_raise_exn"}\n`; - `{record_frame Reg.Set.empty i.dbg}\n`; 1 - | false, _ - | true, Lambda.Raise_notrace -> + `{record_frame Reg.Set.empty true i.dbg}\n`; 1 + | Cmm.Raise_notrace -> ` mov sp, trap_ptr\n`; ` pop \{trap_ptr, pc}\n`; 2 end @@ -875,7 +879,6 @@ let fundecl fundecl = let emit_item = function Cglobal_symbol s -> ` .globl {emit_symbol s}\n`; | Cdefine_symbol s -> `{emit_symbol s}:\n` - | Cdefine_label lbl -> `{emit_data_label lbl}:\n` | Cint8 n -> ` .byte {emit_int n}\n` | Cint16 n -> ` .short {emit_int n}\n` | Cint32 n -> ` .long {emit_int32 (Nativeint.to_int32 n)}\n` @@ -883,7 +886,6 @@ let emit_item = function | Csingle f -> emit_float32_directive ".long" (Int32.bits_of_float f) | Cdouble f -> emit_float64_split_directive ".long" (Int64.bits_of_float f) | Csymbol_address s -> ` .word {emit_symbol s}\n` - | Clabel_address lbl -> ` .word {emit_data_label lbl}\n` | Cstring s -> emit_string_directive " .ascii " s | Cskip n -> if n > 0 then ` .space {emit_int n}\n` | Calign n -> ` .align {emit_int(Misc.log2 n)}\n` @@ -938,9 +940,12 @@ let end_assembly () = ` .globl {emit_symbol lbl}\n`; `{emit_symbol lbl}:\n`; emit_frames - { efa_label = (fun lbl -> + { efa_code_label = (fun lbl -> ` .type {emit_label lbl}, %function\n`; ` .word {emit_label lbl}\n`); + efa_data_label = (fun lbl -> + ` .type {emit_label lbl}, %object\n`; + ` .word {emit_label lbl}\n`); efa_16 = (fun n -> ` .short {emit_int n}\n`); efa_32 = (fun n -> ` .long {emit_int32 n}\n`); efa_word = (fun n -> ` .word {emit_int n}\n`); diff --git a/asmcomp/arm/proc.ml b/asmcomp/arm/proc.ml index a204cfff..64d9013f 100644 --- a/asmcomp/arm/proc.ml +++ b/asmcomp/arm/proc.ml @@ -107,6 +107,8 @@ let phys_reg n = let stack_slot slot ty = Reg.at_location ty (Stack slot) +let loc_spacetime_node_hole = Reg.dummy (* Spacetime unsupported *) + (* Calling conventions *) let calling_conventions first_int last_int first_float last_float make_stack @@ -175,7 +177,7 @@ let calling_conventions first_int last_int first_float last_float make_stack let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs -let not_supported ofs = fatal_error "Proc.loc_results: cannot call" +let not_supported _ofs = fatal_error "Proc.loc_results: cannot call" (* OCaml calling convention: first integer args in r0...r7 @@ -224,7 +226,7 @@ let loc_exn_bucket = phys_reg 0 (* Volatile registers: none *) -let regs_are_volatile rs = false +let regs_are_volatile _rs = false (* Registers destroyed by operations *) @@ -252,10 +254,10 @@ let destroyed_at_c_call = 124;125;126;127;128;129;130;131])) let destroyed_at_oper = function - Iop(Icall_ind | Icall_imm _) - | Iop(Iextcall(_, true)) -> + Iop(Icall_ind _ | Icall_imm _) + | Iop(Iextcall { alloc = true; _ }) -> all_phys_regs - | Iop(Iextcall(_, false)) -> + | Iop(Iextcall { alloc = false; _}) -> destroyed_at_c_call | Iop(Ialloc _) -> destroyed_at_alloc @@ -272,14 +274,14 @@ let destroyed_at_raise = all_phys_regs (* Maximal register pressure *) let safe_register_pressure = function - Iextcall(_, _) -> if abi = EABI then 0 else 4 + Iextcall _ -> if abi = EABI then 0 else 4 | Ialloc _ -> if abi = EABI then 0 else 7 | Iconst_symbol _ when !Clflags.pic_code -> 7 | Iintop Imulh when !arch < ARMv6 -> 8 | _ -> 9 let max_register_pressure = function - Iextcall(_, _) -> if abi = EABI then [| 4; 0; 0 |] else [| 4; 8; 8 |] + Iextcall _ -> if abi = EABI then [| 4; 0; 0 |] else [| 4; 8; 8 |] | Ialloc _ -> if abi = EABI then [| 7; 0; 0 |] else [| 7; 8; 8 |] | Iconst_symbol _ when !Clflags.pic_code -> [| 7; 16; 32 |] | Iintoffloat | Ifloatofint @@ -291,9 +293,9 @@ let max_register_pressure = function registers). *) let op_is_pure = function - | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _ | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ - | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) + | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _) | Ispecific(Ishiftcheckbound _) -> false | _ -> true diff --git a/asmcomp/arm/scheduling.ml b/asmcomp/arm/scheduling.ml index c89d628a..4039eaac 100644 --- a/asmcomp/arm/scheduling.ml +++ b/asmcomp/arm/scheduling.ml @@ -19,7 +19,7 @@ open Mach (* Instruction scheduling for the ARM *) -class scheduler = object(self) +class scheduler = object inherit Schedgen.scheduler_generic as super @@ -58,8 +58,8 @@ method oper_issue_cycles = function | Iintop(Ilsl | Ilsr | Iasr) -> 2 | Iintop(Icomp _) | Iintop_imm(Icomp _, _) -> 3 - | Iintop(Icheckbound) - | Iintop_imm(Icheckbound, _) -> 2 + | Iintop(Icheckbound _) + | Iintop_imm(Icheckbound _, _) -> 2 | Ispecific(Ishiftcheckbound _) -> 3 | Iintop(Imul | Imulh) | Ispecific(Imuladd | Imulsub | Imulhadd) -> 2 diff --git a/asmcomp/arm/selection.ml b/asmcomp/arm/selection.ml index d363c556..2063e606 100644 --- a/asmcomp/arm/selection.ml +++ b/asmcomp/arm/selection.ml @@ -53,7 +53,6 @@ exception Use_default let r1 = phys_reg 1 let r6 = phys_reg 6 let r7 = phys_reg 7 -let r12 = phys_reg 8 let pseudoregs_for_operation op arg res = match op with @@ -79,7 +78,7 @@ let pseudoregs_for_operation op arg res = (arg', res) (* We use __aeabi_idivmod for Cmodi only, and hence we care only for the remainder in r1, so fix up the destination register. *) - | Iextcall("__aeabi_idivmod", false) -> + | Iextcall { func = "__aeabi_idivmod"; alloc = false; } -> (arg, [|r1|]) (* Other instructions are regular *) | _ -> raise Use_default @@ -108,12 +107,14 @@ method is_immediate n = method! is_simple_expr = function (* inlined floating-point ops are simple if their arguments are *) - | Cop(Cextcall("sqrt", _, _, _), args) when !fpu >= VFPv2 -> + | Cop(Cextcall("sqrt", _, _, _, _), args) when !fpu >= VFPv2 -> List.for_all self#is_simple_expr args (* inlined byte-swap ops are simple if their arguments are *) - | Cop(Cextcall("caml_bswap16_direct", _, _, _), args) when !arch >= ARMv6T2 -> + | Cop(Cextcall("caml_bswap16_direct", _, _, _, _), args) + when !arch >= ARMv6T2 -> List.for_all self#is_simple_expr args - | Cop(Cextcall("caml_int32_direct_bswap", _,_,_), args) when !arch >= ARMv6 -> + | Cop(Cextcall("caml_int32_direct_bswap", _,_,_,_), args) + when !arch >= ARMv6 -> List.for_all self#is_simple_expr args | e -> super#is_simple_expr e @@ -165,6 +166,9 @@ method select_shift_arith op arithop arithrevop args = | op_args -> op_args end +method private iextcall (func, alloc) = + Iextcall { func; alloc; label_after = Cmm.new_label (); } + method! select_operation op args = match (op, args) with (* Recognize special shift arithmetic *) @@ -197,15 +201,16 @@ method! select_operation op args = (Iintop Imulh, args) (* Turn integer division/modulus into runtime ABI calls *) | (Cdivi, args) -> - (Iextcall("__aeabi_idiv", false), args) + (self#iextcall("__aeabi_idiv", false), args) | (Cmodi, args) -> (* See above for fix up of return register *) - (Iextcall("__aeabi_idivmod", false), args) + (self#iextcall("__aeabi_idivmod", false), args) (* Recognize 16-bit bswap instruction (ARMv6T2 because we need movt) *) - | (Cextcall("caml_bswap16_direct", _, _, _), args) when !arch >= ARMv6T2 -> + | (Cextcall("caml_bswap16_direct", _, _, _, _), args) when !arch >= ARMv6T2 -> (Ispecific(Ibswap 16), args) (* Recognize 32-bit bswap instructions (ARMv6 and above) *) - | (Cextcall("caml_int32_direct_bswap", _, _, _), args) when !arch >= ARMv6 -> + | (Cextcall("caml_int32_direct_bswap", _, _, _, _), args) + when !arch >= ARMv6 -> (Ispecific(Ibswap 32), args) (* Turn floating-point operations into runtime ABI calls for softfp *) | (op, args) when !fpu = Soft -> self#select_operation_softfp op args @@ -215,12 +220,12 @@ method! select_operation op args = method private select_operation_softfp op args = match (op, args) with (* Turn floating-point operations into runtime ABI calls *) - | (Caddf, args) -> (Iextcall("__aeabi_dadd", false), args) - | (Csubf, args) -> (Iextcall("__aeabi_dsub", false), args) - | (Cmulf, args) -> (Iextcall("__aeabi_dmul", false), args) - | (Cdivf, args) -> (Iextcall("__aeabi_ddiv", false), args) - | (Cfloatofint, args) -> (Iextcall("__aeabi_i2d", false), args) - | (Cintoffloat, args) -> (Iextcall("__aeabi_d2iz", false), args) + | (Caddf, args) -> (self#iextcall("__aeabi_dadd", false), args) + | (Csubf, args) -> (self#iextcall("__aeabi_dsub", false), args) + | (Cmulf, args) -> (self#iextcall("__aeabi_dmul", false), args) + | (Cdivf, args) -> (self#iextcall("__aeabi_ddiv", false), args) + | (Cfloatofint, args) -> (self#iextcall("__aeabi_i2d", false), args) + | (Cintoffloat, args) -> (self#iextcall("__aeabi_d2iz", false), args) | (Ccmpf comp, args) -> let func = (match comp with Cne (* there's no __aeabi_dcmpne *) @@ -233,13 +238,13 @@ method private select_operation_softfp op args = Cne -> Ceq (* eq 0 => false *) | _ -> Cne (* ne 0 => true *)) in (Iintop_imm(Icomp(Iunsigned comp), 0), - [Cop(Cextcall(func, typ_int, false, Debuginfo.none), args)]) + [Cop(Cextcall(func, typ_int, false, Debuginfo.none, None), args)]) (* Add coercions around loads and stores of 32-bit floats *) | (Cload Single, args) -> - (Iextcall("__aeabi_f2d", false), [Cop(Cload Word_int, args)]) + (self#iextcall("__aeabi_f2d", false), [Cop(Cload Word_int, args)]) | (Cstore (Single, init), [arg1; arg2]) -> let arg2' = - Cop(Cextcall("__aeabi_d2f", typ_int, false, Debuginfo.none), + Cop(Cextcall("__aeabi_d2f", typ_int, false, Debuginfo.none, None), [arg2]) in self#select_operation (Cstore (Word_int, init)) [arg1; arg2'] (* Other operations are regular *) @@ -265,7 +270,7 @@ method private select_operation_vfpv3 op args = | (Csubf, [Cop(Cmulf, args); arg]) -> (Ispecific Imulsubf, arg :: args) (* Recognize floating-point square root *) - | (Cextcall("sqrt", _, false, _), args) -> + | (Cextcall("sqrt", _, false, _, _), args) -> (Ispecific Isqrtf, args) (* Other operations are regular *) | (op, args) -> super#select_operation op args diff --git a/asmcomp/arm64/CSE.ml b/asmcomp/arm64/CSE.ml index 7a8fc17f..b97f9227 100644 --- a/asmcomp/arm64/CSE.ml +++ b/asmcomp/arm64/CSE.ml @@ -19,7 +19,7 @@ open Arch open Mach open CSEgen -class cse = object (self) +class cse = object inherit cse_generic as super @@ -31,7 +31,7 @@ method! class_of_operation op = method! is_cheap_operation op = match op with - | Iconst_int n | Iconst_blockheader n -> n <= 65535n && n >= 0n + | Iconst_int n -> n <= 65535n && n >= 0n | _ -> false end diff --git a/asmcomp/arm64/arch.ml b/asmcomp/arm64/arch.ml index 5c13957f..4eb8b9d9 100644 --- a/asmcomp/arm64/arch.ml +++ b/asmcomp/arm64/arch.ml @@ -15,8 +15,6 @@ (* *) (**************************************************************************) -let command_line_options = [] - (* Specific operations for the ARM processor, 64-bit mode *) open Format @@ -36,13 +34,18 @@ type addressing_mode = (* Specific operations *) +type cmm_label = int + (* Do not introduce a dependency to Cmm *) + type specific_operation = - | Ifar_alloc of int - | Ifar_intop_checkbound - | Ifar_intop_imm_checkbound of int + | Ifar_alloc of { words : int; label_after_call_gc : cmm_label option; } + | Ifar_intop_checkbound of { label_after_error : cmm_label option; } + | Ifar_intop_imm_checkbound of + { bound : int; label_after_error : cmm_label option; } | Ishiftarith of arith_operation * int - | Ishiftcheckbound of int - | Ifar_shiftcheckbound of int + | Ishiftcheckbound of { shift : int; label_after_error : cmm_label option; } + | Ifar_shiftcheckbound of + { shift : int; label_after_error : cmm_label option; } | Imuladd (* multiply and add *) | Imulsub (* multiply and subtract *) | Inegmulf (* floating-point negate and multiply *) @@ -57,6 +60,12 @@ and arith_operation = Ishiftadd | Ishiftsub +let spacetime_node_hole_pointer_is_live_before = function + | Ifar_alloc _ | Ifar_intop_checkbound _ | Ifar_intop_imm_checkbound _ + | Ishiftarith _ | Ishiftcheckbound _ | Ifar_shiftcheckbound _ -> false + | Imuladd | Imulsub | Inegmulf | Imuladdf | Inegmuladdf | Imulsubf + | Inegmulsubf | Isqrtf | Ibswap _ -> false + (* Sizes, endianness *) let big_endian = false @@ -81,8 +90,8 @@ let offset_addressing addr delta = | Ibased(s, n) -> Ibased(s, n + delta) let num_args_addressing = function - | Iindexed n -> 1 - | Ibased(s, n) -> 0 + | Iindexed _ -> 1 + | Ibased _ -> 0 (* Printing operations and addressing modes *) @@ -98,12 +107,12 @@ let print_addressing printreg addr ppf arg = let print_specific_operation printreg op ppf arg = match op with - | Ifar_alloc n -> - fprintf ppf "(far) alloc %i" n - | Ifar_intop_checkbound -> + | Ifar_alloc { words; label_after_call_gc = _; } -> + fprintf ppf "(far) alloc %i" words + | Ifar_intop_checkbound _ -> fprintf ppf "%a (far) check > %a" printreg arg.(0) printreg arg.(1) - | Ifar_intop_imm_checkbound n -> - fprintf ppf "%a (far) check > %i" printreg arg.(0) n + | Ifar_intop_imm_checkbound { bound; _ } -> + fprintf ppf "%a (far) check > %i" printreg arg.(0) bound | Ishiftarith(op, shift) -> let op_name = function | Ishiftadd -> "+" @@ -114,11 +123,12 @@ let print_specific_operation printreg op ppf arg = else sprintf ">> %i" (-shift) in fprintf ppf "%a %s %a %s" printreg arg.(0) (op_name op) printreg arg.(1) shift_mark - | Ishiftcheckbound n -> - fprintf ppf "check %a >> %i > %a" printreg arg.(0) n printreg arg.(1) - | Ifar_shiftcheckbound n -> + | Ishiftcheckbound { shift; _ } -> + fprintf ppf "check %a >> %i > %a" printreg arg.(0) shift + printreg arg.(1) + | Ifar_shiftcheckbound { shift; _ } -> fprintf ppf - "(far) check %a >> %i > %a" printreg arg.(0) n printreg arg.(1) + "(far) check %a >> %i > %a" printreg arg.(0) shift printreg arg.(1) | Imuladd -> fprintf ppf "(%a * %a) + %a" printreg arg.(0) diff --git a/asmcomp/arm64/emit.mlp b/asmcomp/arm64/emit.mlp index 9cca60b2..b67723a8 100644 --- a/asmcomp/arm64/emit.mlp +++ b/asmcomp/arm64/emit.mlp @@ -1,3 +1,4 @@ +#2 "asmcomp/arm64/emit.mlp" (**************************************************************************) (* *) (* OCaml *) @@ -36,7 +37,6 @@ let reg_trap_ptr = phys_reg 23 let reg_alloc_ptr = phys_reg 24 let reg_alloc_limit = phys_reg 25 let reg_tmp1 = phys_reg 26 -let reg_tmp2 = phys_reg 27 let reg_x15 = phys_reg 15 (* Output a label *) @@ -44,9 +44,6 @@ let reg_x15 = phys_reg 15 let emit_label lbl = emit_string ".L"; emit_int lbl -let emit_data_label lbl = - emit_string ".Ld"; emit_int lbl - (* Symbols *) let emit_symbol s = @@ -121,8 +118,12 @@ let emit_addressing addr r = (* Record live pointers at call points *) -let record_frame_label live dbg = - let lbl = new_label() in +let record_frame_label ?label live raise_ dbg = + let lbl = + match label with + | None -> new_label() + | Some label -> label + in let live_offset = ref [] in Reg.Set.iter (function @@ -138,11 +139,12 @@ let record_frame_label live dbg = { fd_lbl = lbl; fd_frame_size = frame_size(); fd_live_offset = !live_offset; + fd_raise = raise_; fd_debuginfo = dbg } :: !frame_descriptors; lbl -let record_frame live dbg = - let lbl = record_frame_label live dbg in `{emit_label lbl}:` +let record_frame ?label live raise_ dbg = + let lbl = record_frame_label ?label live raise_ dbg in `{emit_label lbl}:` (* Record calls to the GC -- we've moved them out of the way *) @@ -167,10 +169,10 @@ type bound_error_call = let bound_error_sites = ref ([] : bound_error_call list) -let bound_error_label dbg = +let bound_error_label ?label dbg = if !Clflags.debug || !bound_error_sites = [] then begin let lbl_bound_error = new_label() in - let lbl_frame = record_frame_label Reg.Set.empty dbg in + let lbl_frame = record_frame_label ?label Reg.Set.empty false dbg in bound_error_sites := { bd_lbl = lbl_bound_error; bd_frame_lbl = lbl_frame } :: !bound_error_sites; @@ -343,8 +345,8 @@ let num_call_gc_and_check_bound_points instr = | Lend -> totals | Lop (Ialloc _) when !fastcode_flag -> loop instr.next (call_gc + 1, check_bound) - | Lop (Iintop Icheckbound) - | Lop (Iintop_imm (Icheckbound, _)) + | Lop (Iintop Icheckbound _) + | Lop (Iintop_imm (Icheckbound _, _)) | Lop (Ispecific (Ishiftcheckbound _)) -> let check_bound = (* When not in debug mode, there is at most one check-bound point. *) @@ -355,14 +357,14 @@ let num_call_gc_and_check_bound_points instr = (* The following four should never be seen, since this function is run before branch relaxation. *) | Lop (Ispecific (Ifar_alloc _)) - | Lop (Ispecific Ifar_intop_checkbound) + | Lop (Ispecific Ifar_intop_checkbound _) | Lop (Ispecific (Ifar_intop_imm_checkbound _)) | Lop (Ispecific (Ifar_shiftcheckbound _)) -> assert false | _ -> loop instr.next totals in loop instr (0, 0) -let max_out_of_line_code_offset instr ~num_call_gc ~num_check_bound = +let max_out_of_line_code_offset ~num_call_gc ~num_check_bound = if num_call_gc < 1 && num_check_bound < 1 then 0 else begin let size_of_call_gc = 2 in @@ -401,8 +403,8 @@ module BR = Branch_relaxation.Make (struct let classify_instr = function | Lop (Ialloc _) - | Lop (Iintop Icheckbound) - | Lop (Iintop_imm (Icheckbound, _)) + | Lop (Iintop Icheckbound _) + | Lop (Iintop_imm (Icheckbound _, _)) | Lop (Ispecific (Ishiftcheckbound _)) -> Some Bcc (* The various "far" variants in [specific_operation] don't need to return [Some] here, since their code sequences never contain any @@ -426,33 +428,34 @@ module BR = Branch_relaxation.Make (struct let instr_size = function | Lend -> 0 | Lop (Imove | Ispill | Ireload) -> 1 - | Lop (Iconst_int n | Iconst_blockheader n) -> + | Lop (Iconst_int n) -> num_instructions_for_intconst n | Lop (Iconst_float _) -> 2 | Lop (Iconst_symbol _) -> 2 - | Lop (Icall_ind) -> 1 + | Lop (Icall_ind _) -> 1 | Lop (Icall_imm _) -> 1 - | Lop (Itailcall_ind) -> epilogue_size () - | Lop (Itailcall_imm s) -> - if s = !function_name then 1 else epilogue_size () - | Lop (Iextcall (_, false)) -> 1 - | Lop (Iextcall (_, true)) -> 3 + | Lop (Itailcall_ind _) -> epilogue_size () + | Lop (Itailcall_imm { func; _ }) -> + if func = !function_name then 1 else epilogue_size () + | Lop (Iextcall { alloc = false; }) -> 1 + | Lop (Iextcall { alloc = true; }) -> 3 | Lop (Istackoffset _) -> 2 | Lop (Iload (size, addr)) | Lop (Istore (size, addr, _)) -> let based = match addr with Iindexed _ -> 0 | Ibased _ -> 1 in based + begin match size with Single -> 2 | _ -> 1 end | Lop (Ialloc _) when !fastcode_flag -> 4 | Lop (Ispecific (Ifar_alloc _)) when !fastcode_flag -> 5 - | Lop (Ialloc num_words) | Lop (Ispecific (Ifar_alloc num_words)) -> + | Lop (Ialloc { words = num_words; _ }) + | Lop (Ispecific (Ifar_alloc { words = num_words; _ })) -> begin match num_words with | 16 | 24 | 32 -> 1 | _ -> 1 + num_instructions_for_intconst (Nativeint.of_int num_words) end | Lop (Iintop (Icomp _)) -> 2 | Lop (Iintop_imm (Icomp _, _)) -> 2 - | Lop (Iintop Icheckbound) -> 2 - | Lop (Ispecific Ifar_intop_checkbound) -> 3 - | Lop (Iintop_imm (Icheckbound, _)) -> 2 + | Lop (Iintop (Icheckbound _)) -> 2 + | Lop (Ispecific (Ifar_intop_checkbound _)) -> 3 + | Lop (Iintop_imm (Icheckbound _, _)) -> 2 | Lop (Ispecific (Ifar_intop_imm_checkbound _)) -> 3 | Lop (Ispecific (Ishiftcheckbound _)) -> 2 | Lop (Ispecific (Ifar_shiftcheckbound _)) -> 3 @@ -490,30 +493,32 @@ module BR = Branch_relaxation.Make (struct | Lpushtrap -> 3 | Lpoptrap -> 1 | Lraise k -> - begin match !Clflags.debug, k with - | true, (Lambda.Raise_regular | Lambda.Raise_reraise) -> 1 - | false, _ - | true, Lambda.Raise_notrace -> 4 + begin match k with + | Cmm.Raise_withtrace -> 1 + | Cmm.Raise_notrace -> 4 end - let relax_allocation ~num_words = - Lop (Ispecific (Ifar_alloc num_words)) + let relax_allocation ~num_words ~label_after_call_gc = + Lop (Ispecific (Ifar_alloc { words = num_words; label_after_call_gc; })) - let relax_intop_checkbound () = - Lop (Ispecific Ifar_intop_checkbound) + let relax_intop_checkbound ~label_after_error = + Lop (Ispecific (Ifar_intop_checkbound { label_after_error; })) - let relax_intop_imm_checkbound ~bound = - Lop (Ispecific (Ifar_intop_imm_checkbound bound)) + let relax_intop_imm_checkbound ~bound ~label_after_error = + Lop (Ispecific (Ifar_intop_imm_checkbound { bound; label_after_error; })) let relax_specific_op = function - | Ishiftcheckbound shift -> Lop (Ispecific (Ifar_shiftcheckbound shift)) + | Ishiftcheckbound { shift; label_after_error; } -> + Lop (Ispecific (Ifar_shiftcheckbound { shift; label_after_error; })) | _ -> assert false end) (* Output the assembly code for allocation. *) -let assembly_code_for_allocation i ~n ~far = - let lbl_frame = record_frame_label i.live i.dbg in +let assembly_code_for_allocation ?label_after_call_gc i ~n ~far = + let lbl_frame = + record_frame_label ?label:label_after_call_gc i.live false i.dbg + in if !fastcode_flag then begin let lbl_redo = new_label() in let lbl_call_gc = new_label() in @@ -565,7 +570,7 @@ let emit_instr i = | _ -> assert false end - | Lop(Iconst_int n | Iconst_blockheader n) -> + | Lop(Iconst_int n) -> emit_intconst i.res.(0) n | Lop(Iconst_float f) -> if f = 0L then @@ -579,25 +584,25 @@ let emit_instr i = end | Lop(Iconst_symbol s) -> emit_load_symbol_addr i.res.(0) s - | Lop(Icall_ind) -> + | Lop(Icall_ind { label_after; }) -> ` blr {emit_reg i.arg.(0)}\n`; - `{record_frame i.live i.dbg}\n` - | Lop(Icall_imm s) -> - ` bl {emit_symbol s}\n`; - `{record_frame i.live i.dbg}\n` - | Lop(Itailcall_ind) -> + `{record_frame i.live false i.dbg ~label:label_after}\n` + | Lop(Icall_imm { func; label_after; }) -> + ` bl {emit_symbol func}\n`; + `{record_frame i.live false i.dbg ~label:label_after}\n` + | Lop(Itailcall_ind { label_after = _; }) -> output_epilogue (fun () -> ` br {emit_reg i.arg.(0)}\n`) - | Lop(Itailcall_imm s) -> - if s = !function_name then + | Lop(Itailcall_imm { func; label_after = _; }) -> + if func = !function_name then ` b {emit_label !tailrec_entry_point}\n` else - output_epilogue (fun () -> ` b {emit_symbol s}\n`) - | Lop(Iextcall(s, false)) -> - ` bl {emit_symbol s}\n` - | Lop(Iextcall(s, true)) -> - emit_load_symbol_addr reg_x15 s; + output_epilogue (fun () -> ` b {emit_symbol func}\n`) + | Lop(Iextcall { func; alloc = false; label_after = _; }) -> + ` bl {emit_symbol func}\n` + | Lop(Iextcall { func; alloc = true; label_after; }) -> + emit_load_symbol_addr reg_x15 func; ` bl {emit_symbol "caml_c_call"}\n`; - `{record_frame i.live i.dbg}\n` + `{record_frame i.live false i.dbg ~label:label_after}\n` | Lop(Istackoffset n) -> assert (n mod 16 = 0); emit_stack_adjustment (-n); @@ -606,7 +611,7 @@ let emit_instr i = let dst = i.res.(0) in let base = match addr with - | Iindexed ofs -> i.arg.(0) + | Iindexed _ -> i.arg.(0) | Ibased(s, ofs) -> ` adrp {emit_reg reg_tmp1}, {emit_symbol_offset s ofs}\n`; reg_tmp1 in @@ -633,7 +638,7 @@ let emit_instr i = let src = i.arg.(0) in let base = match addr with - | Iindexed ofs -> i.arg.(1) + | Iindexed _ -> i.arg.(1) | Ibased(s, ofs) -> ` adrp {emit_reg reg_tmp1}, {emit_symbol_offset s ofs}\n`; reg_tmp1 in @@ -650,44 +655,45 @@ let emit_instr i = | Word_int | Word_val | Double | Double_u -> ` str {emit_reg src}, {emit_addressing addr base}\n` end - | Lop(Ialloc n) -> - assembly_code_for_allocation i ~n ~far:false - | Lop(Ispecific (Ifar_alloc n)) -> - assembly_code_for_allocation i ~n ~far:true + | Lop(Ialloc { words = n; label_after_call_gc; }) -> + assembly_code_for_allocation i ~n ~far:false ?label_after_call_gc + | Lop(Ispecific (Ifar_alloc { words = n; label_after_call_gc; })) -> + assembly_code_for_allocation i ~n ~far:true ?label_after_call_gc | Lop(Iintop(Icomp cmp)) -> ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; ` cset {emit_reg i.res.(0)}, {emit_string (name_for_comparison cmp)}\n` | Lop(Iintop_imm(Icomp cmp, n)) -> ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; ` cset {emit_reg i.res.(0)}, {emit_string (name_for_comparison cmp)}\n` - | Lop(Iintop Icheckbound) -> - let lbl = bound_error_label i.dbg in + | Lop(Iintop (Icheckbound { label_after_error; })) -> + let lbl = bound_error_label i.dbg ?label:label_after_error in ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; ` b.ls {emit_label lbl}\n` - | Lop(Ispecific Ifar_intop_checkbound) -> - let lbl = bound_error_label i.dbg in + | Lop(Ispecific Ifar_intop_checkbound { label_after_error; }) -> + let lbl = bound_error_label i.dbg ?label:label_after_error in let lbl2 = new_label () in ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; ` b.hi {emit_label lbl2}\n`; ` b {emit_label lbl}\n`; `{emit_label lbl2}:\n`; - | Lop(Iintop_imm(Icheckbound, n)) -> - let lbl = bound_error_label i.dbg in + | Lop(Iintop_imm(Icheckbound { label_after_error; }, n)) -> + let lbl = bound_error_label i.dbg ?label:label_after_error in ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; ` b.ls {emit_label lbl}\n` - | Lop(Ispecific(Ifar_intop_imm_checkbound bound)) -> - let lbl = bound_error_label i.dbg in + | Lop(Ispecific( + Ifar_intop_imm_checkbound { bound; label_after_error; })) -> + let lbl = bound_error_label i.dbg ?label:label_after_error in let lbl2 = new_label () in ` cmp {emit_reg i.arg.(0)}, #{emit_int bound}\n`; ` b.hi {emit_label lbl2}\n`; ` b {emit_label lbl}\n`; `{emit_label lbl2}:\n`; - | Lop(Ispecific(Ishiftcheckbound shift)) -> - let lbl = bound_error_label i.dbg in + | Lop(Ispecific(Ishiftcheckbound { shift; label_after_error; })) -> + let lbl = bound_error_label i.dbg ?label:label_after_error in ` cmp {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`; ` b.cs {emit_label lbl}\n` - | Lop(Ispecific(Ifar_shiftcheckbound shift)) -> - let lbl = bound_error_label i.dbg in + | Lop(Ispecific(Ifar_shiftcheckbound { shift; label_after_error; })) -> + let lbl = bound_error_label i.dbg ?label:label_after_error in let lbl2 = new_label () in ` cmp {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`; ` b.lo {emit_label lbl2}\n`; @@ -847,12 +853,11 @@ let emit_instr i = cfi_adjust_cfa_offset (-16); stack_offset := !stack_offset - 16 | Lraise k -> - begin match !Clflags.debug, k with - | true, (Lambda.Raise_regular | Lambda.Raise_reraise) -> + begin match k with + | Cmm.Raise_withtrace -> ` bl {emit_symbol "caml_raise_exn"}\n`; - `{record_frame Reg.Set.empty i.dbg}\n` - | false, _ - | true, Lambda.Raise_notrace -> + `{record_frame Reg.Set.empty true i.dbg}\n` + | Cmm.Raise_notrace -> ` mov sp, {emit_reg reg_trap_ptr}\n`; ` ldr {emit_reg reg_tmp1}, [sp, #8]\n`; ` ldr {emit_reg reg_trap_ptr}, [sp], 16\n`; @@ -905,7 +910,7 @@ let fundecl fundecl = num_call_gc_and_check_bound_points fundecl.fun_body in let max_out_of_line_code_offset = - max_out_of_line_code_offset fundecl.fun_body ~num_call_gc + max_out_of_line_code_offset ~num_call_gc ~num_check_bound in BR.relax fundecl.fun_body ~max_out_of_line_code_offset; @@ -924,7 +929,6 @@ let fundecl fundecl = let emit_item = function | Cglobal_symbol s -> ` .globl {emit_symbol s}\n`; | Cdefine_symbol s -> `{emit_symbol s}:\n` - | Cdefine_label lbl -> `{emit_data_label lbl}:\n` | Cint8 n -> ` .byte {emit_int n}\n` | Cint16 n -> ` .short {emit_int n}\n` | Cint32 n -> ` .long {emit_nativeint n}\n` @@ -932,7 +936,6 @@ let emit_item = function | Csingle f -> emit_float32_directive ".long" (Int32.bits_of_float f) | Cdouble f -> emit_float64_directive ".quad" (Int64.bits_of_float f) | Csymbol_address s -> ` .quad {emit_symbol s}\n` - | Clabel_address lbl -> ` .quad {emit_data_label lbl}\n` | Cstring s -> emit_string_directive " .ascii " s | Cskip n -> if n > 0 then ` .space {emit_int n}\n` | Calign n -> ` .align {emit_int(Misc.log2 n)}\n` @@ -970,9 +973,12 @@ let end_assembly () = ` .globl {emit_symbol lbl}\n`; `{emit_symbol lbl}:\n`; emit_frames - { efa_label = (fun lbl -> + { efa_code_label = (fun lbl -> ` .type {emit_label lbl}, %function\n`; ` .quad {emit_label lbl}\n`); + efa_data_label = (fun lbl -> + ` .type {emit_label lbl}, %object\n`; + ` .quad {emit_label lbl}\n`); efa_16 = (fun n -> ` .short {emit_int n}\n`); efa_32 = (fun n -> ` .long {emit_int32 n}\n`); efa_word = (fun n -> ` .quad {emit_int n}\n`); diff --git a/asmcomp/arm64/proc.ml b/asmcomp/arm64/proc.ml index 86cfb51e..94062bbf 100644 --- a/asmcomp/arm64/proc.ml +++ b/asmcomp/arm64/proc.ml @@ -104,6 +104,8 @@ let reg_d7 = phys_reg 107 let stack_slot slot ty = Reg.at_location ty (Stack slot) +let loc_spacetime_node_hole = Reg.dummy (* Spacetime unsupported *) + (* Calling conventions *) let calling_conventions @@ -135,7 +137,7 @@ let calling_conventions let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs -let not_supported ofs = fatal_error "Proc.loc_results: cannot call" +let not_supported _ofs = fatal_error "Proc.loc_results: cannot call" (* OCaml calling convention: first integer args in r0...r15 @@ -171,7 +173,7 @@ let loc_exn_bucket = phys_reg 0 (* Volatile registers: none *) -let regs_are_volatile rs = false +let regs_are_volatile _rs = false (* Registers destroyed by operations *) @@ -184,9 +186,9 @@ let destroyed_at_c_call = 124;125;126;127;128;129;130;131]) let destroyed_at_oper = function - | Iop(Icall_ind | Icall_imm _) | Iop(Iextcall(_, true)) -> + | Iop(Icall_ind _ | Icall_imm _) | Iop(Iextcall { alloc = true; }) -> all_phys_regs - | Iop(Iextcall(_, false)) -> + | Iop(Iextcall { alloc = false; }) -> destroyed_at_c_call | Iop(Ialloc _) -> [| reg_x15 |] @@ -199,12 +201,12 @@ let destroyed_at_raise = all_phys_regs (* Maximal register pressure *) let safe_register_pressure = function - | Iextcall(_, _) -> 8 + | Iextcall _ -> 8 | Ialloc _ -> 25 | _ -> 26 let max_register_pressure = function - | Iextcall(_, _) -> [| 10; 8 |] + | Iextcall _ -> [| 10; 8 |] | Ialloc _ -> [| 25; 32 |] | Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _, _) -> [| 26; 31 |] @@ -214,9 +216,9 @@ let max_register_pressure = function registers). *) let op_is_pure = function - | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _ | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ - | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) + | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _) | Ispecific(Ishiftcheckbound _) -> false | _ -> true diff --git a/asmcomp/arm64/selection.ml b/asmcomp/arm64/selection.ml index d7d55a93..719c5ec2 100644 --- a/asmcomp/arm64/selection.ml +++ b/asmcomp/arm64/selection.ml @@ -76,10 +76,6 @@ let rec run_automata nbits state input = let is_logical_immediate n = n <> 0 && n <> -1 && run_automata 64 0 n -let is_intconst = function - Cconst_int _ -> true - | _ -> false - let inline_ops = [ "sqrt"; "caml_bswap16_direct"; "caml_int32_direct_bswap"; "caml_int64_direct_bswap"; "caml_nativeint_direct_bswap" ] @@ -100,7 +96,7 @@ method is_immediate n = method! is_simple_expr = function (* inlined floating-point ops are simple if their arguments are *) - | Cop(Cextcall(fn, _, _, _), args) when List.mem fn inline_ops -> + | Cop(Cextcall (fn, _, _, _, _), args) when List.mem fn inline_ops -> List.for_all self#is_simple_expr args | e -> super#is_simple_expr e @@ -183,7 +179,8 @@ method! select_operation op args = | Ccheckbound _ -> begin match args with | [Cop(Clsr, [arg1; Cconst_int n]); arg2] when n > 0 && n < 64 -> - (Ispecific(Ishiftcheckbound n), [arg1; arg2]) + (Ispecific(Ishiftcheckbound { shift = n; label_after_error = None; }), + [arg1; arg2]) | _ -> super#select_operation op args end @@ -222,15 +219,15 @@ method! select_operation op args = super#select_operation op args end (* Recognize floating-point square root *) - | Cextcall("sqrt", _, _, _) -> + | Cextcall("sqrt", _, _, _, _) -> (Ispecific Isqrtf, args) (* Recognize bswap instructions *) - | Cextcall("caml_bswap16_direct", _, _, _) -> + | Cextcall("caml_bswap16_direct", _, _, _, _) -> (Ispecific(Ibswap 16), args) - | Cextcall("caml_int32_direct_bswap", _, _, _) -> + | Cextcall("caml_int32_direct_bswap", _, _, _, _) -> (Ispecific(Ibswap 32), args) | Cextcall(("caml_int64_direct_bswap"|"caml_nativeint_direct_bswap"), - _, _, _) -> + _, _, _, _) -> (Ispecific (Ibswap 64), args) (* Other operations are regular *) | _ -> diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml index b365e411..020732dd 100644 --- a/asmcomp/asmgen.ml +++ b/asmcomp/asmgen.ml @@ -63,9 +63,9 @@ type clambda_and_constants = let raw_clambda_dump_if ppf ((ulambda, _, structured_constants):clambda_and_constants) = - if !dump_rawclambda then + if !dump_rawclambda || !dump_clambda then begin - Format.fprintf ppf "@.clambda (before Un_anf):@."; + Format.fprintf ppf "@.clambda:@."; Printclambda.clambda ppf ulambda; List.iter (fun {Clambda.symbol; definition} -> Format.fprintf ppf "%s:@ %a@." @@ -233,7 +233,7 @@ let lambda_gen_implementation ?toplevel ~source_provenance ppf end_gen_implementation ?toplevel ~source_provenance ppf clambda_and_constants let compile_implementation_gen ?toplevel ~source_provenance prefixname - ppf gen_implementation program = + ~required_globals ppf gen_implementation program = let asmfile = if !keep_asm_file || !Emitaux.binary_backend_available then prefixname ^ ext_asm @@ -241,17 +241,19 @@ let compile_implementation_gen ?toplevel ~source_provenance prefixname in compile_unit ~source_provenance prefixname asmfile !keep_asm_file (prefixname ^ ext_obj) (fun () -> + Ident.Set.iter Compilenv.require_global required_globals; 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 + ~required_globals:program.Lambda.required_globals ppf lambda_gen_implementation program let compile_implementation_flambda ?toplevel ~source_provenance prefixname - ~backend ppf (program:Flambda.program) = + ~required_globals ~backend ppf (program:Flambda.program) = compile_implementation_gen ?toplevel ~source_provenance prefixname - ppf (flambda_gen_implementation ~backend) program + ~required_globals ppf (flambda_gen_implementation ~backend) program (* Error report *) diff --git a/asmcomp/asmgen.mli b/asmcomp/asmgen.mli index fc929878..cc79edf9 100644 --- a/asmcomp/asmgen.mli +++ b/asmcomp/asmgen.mli @@ -19,6 +19,7 @@ val compile_implementation_flambda : ?toplevel:(string -> bool) -> source_provenance:Timings.source_provenance -> string -> + required_globals:Ident.Set.t -> backend:(module Backend_intf.S) -> Format.formatter -> Flambda.program -> unit diff --git a/asmcomp/asmlibrarian.ml b/asmcomp/asmlibrarian.ml index b5002c18..ca3f5740 100644 --- a/asmcomp/asmlibrarian.ml +++ b/asmcomp/asmlibrarian.ml @@ -47,7 +47,7 @@ let read_info name = (Filename.chop_suffix filename ".cmx" ^ ext_obj, (info, crc)) let create_archive file_list lib_name = - let archive_name = chop_extension_if_any lib_name ^ ext_lib in + let archive_name = Filename.remove_extension lib_name ^ ext_lib in let outchan = open_out_bin lib_name in try output_string outchan cmxa_magic_number; diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index 254dec7b..fee71787 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -135,7 +135,7 @@ let is_required name = try ignore (Hashtbl.find missing_globals name); true with Not_found -> false -let add_required by (name, crc) = +let add_required by (name, _crc) = try let rq = Hashtbl.find missing_globals name in rq := by :: !rq @@ -233,8 +233,11 @@ let make_startup_file ppf units_list = units_list)); compile_phrase(Cmmgen.data_segment_table ("_startup" :: name_list)); compile_phrase(Cmmgen.code_segment_table ("_startup" :: name_list)); - compile_phrase - (Cmmgen.frame_table("_startup" :: "_system" :: name_list)); + let all_names = "_startup" :: "_system" :: name_list in + compile_phrase (Cmmgen.frame_table all_names); + if Config.spacetime then begin + compile_phrase (Cmmgen.spacetime_shapes all_names); + end; Emit.end_assembly () let make_shared_startup_file ppf units = @@ -286,9 +289,14 @@ let call_linker file_list startup_file output_name = and main_obj_runtime = !Clflags.output_complete_object in let files = startup_file :: (List.rev file_list) in + let libunwind = + if not Config.spacetime then [] + else if not Config.libunwind_available then [] + else String.split_on_char ' ' Config.libunwind_link_flags + in let files, c_lib = if (not !Clflags.output_c_object) || main_dll || main_obj_runtime then - files @ (List.rev !Clflags.ccobjs) @ runtime_lib (), + files @ (List.rev !Clflags.ccobjs) @ runtime_lib () @ libunwind, (if !Clflags.nopervasives || main_obj_runtime then "" else Config.native_c_libraries) else diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml index 9ecebef8..6f0db063 100644 --- a/asmcomp/asmpackager.ml +++ b/asmcomp/asmpackager.ml @@ -82,7 +82,7 @@ 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 + then Filename.remove_extension targetobj ^ ".pack" ^ Config.ext_obj else (* Put the full name of the module in the temporary file name to avoid collisions with MSVC's link /lib in case of successive @@ -97,12 +97,9 @@ let make_package_object ppf members targetobj targetname coercion members in let module_ident = Ident.create_persistent targetname in let source_provenance = Timings.Pack targetname in - let prefixname = chop_extension_if_any objtemp in + let prefixname = Filename.remove_extension objtemp in if Config.flambda then begin - let size, lam = - Translmod.transl_package_flambda - components module_ident coercion - in + let size, lam = Translmod.transl_package_flambda components coercion in let flam = Middle_end.middle_end ppf ~source_provenance @@ -114,17 +111,18 @@ let make_package_object ppf members targetobj targetname coercion ~module_initializer:lam in Asmgen.compile_implementation_flambda ~source_provenance - prefixname ~backend ppf flam; + prefixname ~backend ~required_globals:Ident.Set.empty 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; } + prefixname ppf { Lambda.code; main_module_block_size; + module_ident; required_globals = Ident.Set.empty } end; let objfiles = List.map - (fun m -> chop_extension_if_any m.pm_file ^ Config.ext_obj) + (fun m -> Filename.remove_extension m.pm_file ^ Config.ext_obj) (List.filter (fun m -> m.pm_kind <> PM_intf) members) in let ok = Ccomp.call_linker Ccomp.Partial targetobj (objtemp :: objfiles) "" @@ -150,7 +148,7 @@ let build_package_cmx members cmxfile = let unit_names = List.map (fun m -> m.pm_name) members in let filter lst = - List.filter (fun (name, crc) -> not (List.mem name unit_names)) lst in + List.filter (fun (name, _crc) -> not (List.mem name unit_names)) lst in let union lst = List.fold_left (List.fold_left @@ -244,7 +242,7 @@ let package_files ppf initial_env files targetcmx ~backend = files in let prefix = chop_extensions targetcmx in let targetcmi = prefix ^ ".cmi" in - let targetobj = chop_extension_if_any targetcmx ^ Config.ext_obj in + let targetobj = Filename.remove_extension targetcmx ^ Config.ext_obj in let targetname = String.capitalize_ascii(Filename.basename prefix) in (* Set the name of the current "input" *) Location.input_name := targetcmx; diff --git a/asmcomp/branch_relaxation.ml b/asmcomp/branch_relaxation.ml index 4ef09865..6486d19c 100644 --- a/asmcomp/branch_relaxation.ml +++ b/asmcomp/branch_relaxation.ml @@ -51,8 +51,8 @@ module Make (T : Branch_relaxation_intf.S) = struct in match instr.desc with | Lop (Ialloc _) - | Lop (Iintop Icheckbound) - | Lop (Iintop_imm (Icheckbound, _)) + | Lop (Iintop (Icheckbound _)) + | Lop (Iintop_imm (Icheckbound _, _)) | Lop (Ispecific _) -> (* We assume that any branches eligible for relaxation generated by these instructions only branch forward. We further assume @@ -86,20 +86,21 @@ module Make (T : Branch_relaxation_intf.S) = struct fixup did_fix (pc + T.instr_size instr.desc) instr.next else match instr.desc with - | Lop (Ialloc num_words) -> - instr.desc <- T.relax_allocation ~num_words; + | Lop (Ialloc { words = num_words; label_after_call_gc; }) -> + instr.desc <- T.relax_allocation ~num_words ~label_after_call_gc; fixup true (pc + T.instr_size instr.desc) instr.next - | Lop (Iintop Icheckbound) -> - instr.desc <- T.relax_intop_checkbound (); + | Lop (Iintop (Icheckbound { label_after_error; })) -> + instr.desc <- T.relax_intop_checkbound ~label_after_error; fixup true (pc + T.instr_size instr.desc) instr.next - | Lop (Iintop_imm (Icheckbound, bound)) -> - instr.desc <- T.relax_intop_imm_checkbound ~bound; + | Lop (Iintop_imm (Icheckbound { label_after_error; }, bound)) -> + instr.desc + <- T.relax_intop_imm_checkbound ~bound ~label_after_error; fixup true (pc + T.instr_size instr.desc) instr.next | Lop (Ispecific specific) -> instr.desc <- T.relax_specific_op specific; fixup true (pc + T.instr_size instr.desc) instr.next | Lcondbranch (test, lbl) -> - let lbl2 = new_label() in + let lbl2 = Cmm.new_label() in let cont = instr_cons (Lbranch lbl) [||] [||] (instr_cons (Llabel lbl2) [||] [||] instr.next) diff --git a/asmcomp/branch_relaxation_intf.ml b/asmcomp/branch_relaxation_intf.ml index 0bfab4f7..3b1fbac5 100644 --- a/asmcomp/branch_relaxation_intf.ml +++ b/asmcomp/branch_relaxation_intf.ml @@ -60,8 +60,16 @@ module type S = sig (* Insertion of target-specific code to relax operations that cannot be relaxed generically. It is assumed that these rewrites do not change the size of out-of-line code (cf. branch_relaxation.mli). *) - val relax_allocation : num_words:int -> Linearize.instruction_desc - val relax_intop_checkbound : unit -> Linearize.instruction_desc - val relax_intop_imm_checkbound : bound:int -> Linearize.instruction_desc + val relax_allocation + : num_words:int + -> label_after_call_gc:Cmm.label option + -> Linearize.instruction_desc + val relax_intop_checkbound + : label_after_error:Cmm.label option + -> Linearize.instruction_desc + val relax_intop_imm_checkbound + : bound:int + -> label_after_error:Cmm.label option + -> Linearize.instruction_desc val relax_specific_op : Arch.specific_operation -> Linearize.instruction_desc end diff --git a/asmcomp/build_export_info.ml b/asmcomp/build_export_info.ml index 99d47039..80f97f05 100644 --- a/asmcomp/build_export_info.ml +++ b/asmcomp/build_export_info.ml @@ -207,7 +207,7 @@ let rec approx_of_expr (env : Env.t) (flam : Flambda.t) : Export_info.approx = let approx = descr_of_named env defining_expr in let env = Env.add_approx env var approx in approx_of_expr env body - | Let_mutable (_mut_var, _var, body) -> + | Let_mutable { body } -> approx_of_expr env body | Let_rec (defs, body) -> let env = @@ -251,7 +251,7 @@ and descr_of_named (env : Env.t) (named : Flambda.named) Value_id (Env.new_descr env (descr_of_constant const)) | Allocated_const const -> Value_id (Env.new_descr env (descr_of_allocated_constant const)) - | Prim (Pmakeblock (tag, Immutable), args, _dbg) -> + | Prim (Pmakeblock (tag, Immutable, _value_kind), args, _dbg) -> let approxs = List.map (Env.find_approx env) args in let descr : Export_info.descr = Value_block (Tag.create_exn tag, Array.of_list approxs) diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml index 673bf8c8..df4cfc94 100644 --- a/asmcomp/clambda.ml +++ b/asmcomp/clambda.ml @@ -43,7 +43,7 @@ and ulambda = | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t | Uclosure of ufunction list * ulambda list | Uoffset of ulambda * int - | Ulet of Ident.t * ulambda * ulambda + | Ulet of mutable_flag * value_kind * Ident.t * ulambda * ulambda | Uletrec of (Ident.t * ulambda) list * ulambda | Uprim of primitive * ulambda list * Debuginfo.t | Uswitch of ulambda * ulambda_switch @@ -124,7 +124,7 @@ let rec compare_float_lists l1 l2 = let compare_constants c1 c2 = match c1, c2 with - | Uconst_ref(lbl1, c1), Uconst_ref(lbl2, c2) -> String.compare lbl1 lbl2 + | Uconst_ref(lbl1, _c1), Uconst_ref(lbl2, _c2) -> String.compare lbl1 lbl2 (* Same labels -> same constants. Different labels -> different constants, even if the contents match, because of string constants that must not be diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli index f506c7b3..dd989cd9 100644 --- a/asmcomp/clambda.mli +++ b/asmcomp/clambda.mli @@ -43,7 +43,7 @@ and ulambda = | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t | Uclosure of ufunction list * ulambda list | Uoffset of ulambda * int - | Ulet of Ident.t * ulambda * ulambda + | Ulet of mutable_flag * value_kind * Ident.t * ulambda * ulambda | Uletrec of (Ident.t * ulambda) list * ulambda | Uprim of primitive * ulambda list * Debuginfo.t | Uswitch of ulambda * ulambda_switch diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index d06e4c6f..78b7fc3e 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -50,9 +50,9 @@ let rec build_closure_env env_param pos = function and no longer in Cmmgen so that approximations stored in .cmx files contain the right names if the -for-pack option is active. *) -let getglobal id = +let getglobal dbg id = Uprim(Pgetglobal (Ident.create_persistent (Compilenv.symbol_for_global id)), - [], Debuginfo.none) + [], dbg) (* Check if a variable occurs in a [clambda] term. *) @@ -60,14 +60,14 @@ let occurs_var var u = let rec occurs = function Uvar v -> v = var | Uconst _ -> false - | Udirect_apply(lbl, args, _) -> List.exists occurs args + | Udirect_apply(_lbl, args, _) -> List.exists occurs args | Ugeneric_apply(funct, args, _) -> occurs funct || List.exists occurs args - | Uclosure(fundecls, clos) -> List.exists occurs clos - | Uoffset(u, ofs) -> occurs u - | Ulet(id, def, body) -> occurs def || occurs body + | Uclosure(_fundecls, clos) -> List.exists occurs clos + | Uoffset(u, _ofs) -> occurs u + | Ulet(_str, _kind, _id, def, body) -> occurs def || occurs body | Uletrec(decls, body) -> - List.exists (fun (id, u) -> occurs u) decls || occurs body - | Uprim(p, args, _) -> List.exists occurs args + List.exists (fun (_id, u) -> occurs u) decls || occurs body + | Uprim(_p, args, _) -> List.exists occurs args | Uswitch(arg, s) -> occurs arg || occurs_array s.us_actions_consts || occurs_array s.us_actions_blocks @@ -77,12 +77,12 @@ let occurs_var var u = (match d with None -> false | Some d -> occurs d) | Ustaticfail (_, args) -> List.exists occurs args | Ucatch(_, _, body, hdlr) -> occurs body || occurs hdlr - | Utrywith(body, exn, hdlr) -> occurs body || occurs hdlr + | Utrywith(body, _exn, hdlr) -> occurs body || occurs hdlr | Uifthenelse(cond, ifso, ifnot) -> occurs cond || occurs ifso || occurs ifnot | Usequence(u1, u2) -> occurs u1 || occurs u2 | Uwhile(cond, body) -> occurs cond || occurs body - | Ufor(id, lo, hi, dir, body) -> occurs lo || occurs hi || occurs body + | Ufor(_id, lo, hi, _dir, body) -> occurs lo || occurs hi || occurs body | Uassign(id, u) -> id = var || occurs u | Usend(_, met, obj, args, _) -> occurs met || occurs obj || List.exists occurs args @@ -102,12 +102,12 @@ let occurs_var var u = let prim_size prim args = match prim with - Pidentity -> 0 - | Pgetglobal id -> 1 - | Psetglobal id -> 1 - | Pmakeblock(tag, mut) -> 5 + List.length args - | Pfield f -> 1 - | Psetfield(f, isptr, init) -> + Pidentity | Pbytes_to_string | Pbytes_of_string -> 0 + | Pgetglobal _ -> 1 + | Psetglobal _ -> 1 + | Pmakeblock _ -> 5 + List.length args + | Pfield _ -> 1 + | Psetfield(_f, isptr, init) -> begin match init with | Initialization -> 1 (* never causes a write barrier hit *) | Assignment -> @@ -115,13 +115,15 @@ let prim_size prim args = | Pointer -> 4 | Immediate -> 1 end - | Pfloatfield f -> 1 - | Psetfloatfield (f, _) -> 1 + | Pfloatfield _ -> 1 + | Psetfloatfield _ -> 1 | Pduprecord _ -> 10 + List.length args | Pccall p -> (if p.prim_alloc then 10 else 4) + List.length args | Praise _ -> 4 | Pstringlength -> 5 - | Pstringrefs | Pstringsets -> 6 + | Pbyteslength -> 5 + | Pstringrefs -> 6 + | Pbytesrefs | Pbytessets -> 6 | Pmakearray _ -> 5 + List.length args | Parraylength kind -> if kind = Pgenarray then 6 else 2 | Parrayrefu kind -> if kind = Pgenarray then 12 else 2 @@ -140,19 +142,19 @@ let lambda_smaller lam threshold = let rec lambda_size lam = if !size > threshold then raise Exit; match lam with - Uvar v -> () + Uvar _ -> () | Uconst _ -> incr size - | Udirect_apply(fn, args, _) -> + | Udirect_apply(_, args, _) -> size := !size + 4; lambda_list_size args | Ugeneric_apply(fn, args, _) -> size := !size + 6; lambda_size fn; lambda_list_size args - | Uclosure(defs, vars) -> + | Uclosure _ -> raise Exit (* inlining would duplicate function definitions *) - | Uoffset(lam, ofs) -> + | Uoffset(lam, _ofs) -> incr size; lambda_size lam - | Ulet(id, lam, body) -> + | Ulet(_str, _kind, _id, lam, body) -> lambda_size lam; lambda_size body - | Uletrec(bindings, body) -> + | Uletrec _ -> raise Exit (* usually too large *) | Uprim(prim, args, _) -> size := !size + prim_size prim args; @@ -175,7 +177,7 @@ let lambda_smaller lam threshold = | Ustaticfail (_,args) -> lambda_list_size args | Ucatch(_, _, body, handler) -> incr size; lambda_size body; lambda_size handler - | Utrywith(body, id, handler) -> + | Utrywith(body, _id, handler) -> size := !size + 8; lambda_size body; lambda_size handler | Uifthenelse(cond, ifso, ifnot) -> size := !size + 2; @@ -184,9 +186,9 @@ let lambda_smaller lam threshold = lambda_size lam1; lambda_size lam2 | Uwhile(cond, body) -> size := !size + 2; lambda_size cond; lambda_size body - | Ufor(id, low, high, dir, body) -> + | Ufor(_id, low, high, _dir, body) -> size := !size + 4; lambda_size low; lambda_size high; lambda_size body - | Uassign(id, lam) -> + | Uassign(_id, lam) -> incr size; lambda_size lam | Usend(_, met, obj, args, _) -> size := !size + 8; @@ -203,12 +205,12 @@ let lambda_smaller lam threshold = that is without side-effects *and* not containing function definitions *) let rec is_pure_clambda = function - Uvar v -> true + Uvar _ -> true | Uconst _ -> true | Uprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ | - Pccall _ | Praise _ | Poffsetref _ | Pstringsetu | Pstringsets | + Pccall _ | Praise _ | Poffsetref _ | Pbytessetu | Pbytessets | Parraysetu _ | Parraysets _ | Pbigarrayset _), _, _) -> false - | Uprim(p, args, _) -> List.for_all is_pure_clambda args + | Uprim(_, args, _) -> List.for_all is_pure_clambda args | _ -> false (* Simplify primitive operations on known arguments *) @@ -263,8 +265,8 @@ let simplif_arith_prim_pure fpc p (args, approxs) dbg = | Paddint -> make_const_int (n1 + n2) | Psubint -> make_const_int (n1 - n2) | Pmulint -> make_const_int (n1 * n2) - | Pdivint when n2 <> 0 -> make_const_int (n1 / n2) - | Pmodint when n2 <> 0 -> make_const_int (n1 mod n2) + | Pdivint _ when n2 <> 0 -> make_const_int (n1 / n2) + | Pmodint _ when n2 <> 0 -> make_const_int (n1 mod n2) | Pandint -> make_const_int (n1 land n2) | Porint -> make_const_int (n1 lor n2) | Pxorint -> make_const_int (n1 lxor n2) @@ -312,9 +314,9 @@ let simplif_arith_prim_pure fpc p (args, approxs) dbg = | Paddbint Pnativeint -> make_const_natint (Nativeint.add n1 n2) | Psubbint Pnativeint -> make_const_natint (Nativeint.sub n1 n2) | Pmulbint Pnativeint -> make_const_natint (Nativeint.mul n1 n2) - | Pdivbint Pnativeint when n2 <> 0n -> + | Pdivbint {size=Pnativeint} when n2 <> 0n -> make_const_natint (Nativeint.div n1 n2) - | Pmodbint Pnativeint when n2 <> 0n -> + | Pmodbint {size=Pnativeint} when n2 <> 0n -> make_const_natint (Nativeint.rem n1 n2) | Pandbint Pnativeint -> make_const_natint (Nativeint.logand n1 n2) | Porbint Pnativeint -> make_const_natint (Nativeint.logor n1 n2) @@ -350,8 +352,10 @@ let simplif_arith_prim_pure fpc p (args, approxs) dbg = | Paddbint Pint32 -> make_const_int32 (Int32.add n1 n2) | Psubbint Pint32 -> make_const_int32 (Int32.sub n1 n2) | Pmulbint Pint32 -> make_const_int32 (Int32.mul n1 n2) - | Pdivbint Pint32 when n2 <> 0l -> make_const_int32 (Int32.div n1 n2) - | Pmodbint Pint32 when n2 <> 0l -> make_const_int32 (Int32.rem n1 n2) + | Pdivbint {size=Pint32} when n2 <> 0l -> + make_const_int32 (Int32.div n1 n2) + | Pmodbint {size=Pint32} when n2 <> 0l -> + make_const_int32 (Int32.rem n1 n2) | Pandbint Pint32 -> make_const_int32 (Int32.logand n1 n2) | Porbint Pint32 -> make_const_int32 (Int32.logor n1 n2) | Pxorbint Pint32 -> make_const_int32 (Int32.logxor n1 n2) @@ -386,8 +390,10 @@ let simplif_arith_prim_pure fpc p (args, approxs) dbg = | Paddbint Pint64 -> make_const_int64 (Int64.add n1 n2) | Psubbint Pint64 -> make_const_int64 (Int64.sub n1 n2) | Pmulbint Pint64 -> make_const_int64 (Int64.mul n1 n2) - | Pdivbint Pint64 when n2 <> 0L -> make_const_int64 (Int64.div n1 n2) - | Pmodbint Pint64 when n2 <> 0L -> make_const_int64 (Int64.rem n1 n2) + | Pdivbint {size=Pint64} when n2 <> 0L -> + make_const_int64 (Int64.div n1 n2) + | Pmodbint {size=Pint64} when n2 <> 0L -> + make_const_int64 (Int64.rem n1 n2) | Pandbint Pint64 -> make_const_int64 (Int64.logand n1 n2) | Porbint Pint64 -> make_const_int64 (Int64.logor n1 n2) | Pxorbint Pint64 -> make_const_int64 (Int64.logxor n1 n2) @@ -421,7 +427,7 @@ let field_approx n = function let simplif_prim_pure fpc p (args, approxs) dbg = match p, args, approxs with (* Block construction *) - | Pmakeblock(tag, Immutable), _, _ -> + | Pmakeblock(tag, Immutable, _kind), _, _ -> let field = function | Value_const c -> c | _ -> raise Exit @@ -443,10 +449,12 @@ let simplif_prim_pure fpc p (args, approxs) dbg = when n < List.length ul -> (List.nth ul n, field_approx n approx) (* Strings *) - | Pstringlength, _, [ Value_const(Uconst_ref(_, Some (Uconst_string s))) ] -> + | (Pstringlength | Pbyteslength), + _, + [ Value_const(Uconst_ref(_, Some (Uconst_string s))) ] -> make_const_int (String.length s) (* Identity *) - | Pidentity, [arg1], [app1] -> + | (Pidentity | Pbytes_to_string | Pbytes_of_string), [arg1], [app1] -> (arg1, app1) (* Kind test *) | Pisint, _, [a1] -> @@ -466,6 +474,8 @@ let simplif_prim_pure fpc p (args, approxs) dbg = | Ostype_unix -> make_const_bool (Sys.os_type = "Unix") | Ostype_win32 -> make_const_bool (Sys.os_type = "Win32") | Ostype_cygwin -> make_const_bool (Sys.os_type = "Cygwin") + | Backend_type -> + make_const_ptr 0 (* tag 0 is the same as Native here *) end (* Catch-all *) | _ -> @@ -478,7 +488,7 @@ let simplif_prim fpc p (args, approxs as args_approxs) dbg = (* XXX : always return the same approxs as simplif_prim_pure? *) let approx = match p with - | Pmakeblock(_, Immutable) -> + | Pmakeblock(_, Immutable, _kind) -> Value_tuple (Array.of_list approxs) | _ -> Value_unknown @@ -507,17 +517,24 @@ let find_action idxs acts tag = (* Can this happen? *) None +let subst_debuginfo loc dbg = + if !Clflags.debug then + Debuginfo.inline loc dbg + else + dbg -let rec substitute fpc sb ulam = +let rec substitute loc fpc sb ulam = match ulam with Uvar v -> begin try Tbl.find v sb with Not_found -> ulam end | Uconst _ -> ulam | Udirect_apply(lbl, args, dbg) -> - Udirect_apply(lbl, List.map (substitute fpc sb) args, dbg) + let dbg = subst_debuginfo loc dbg in + Udirect_apply(lbl, List.map (substitute loc fpc sb) args, dbg) | Ugeneric_apply(fn, args, dbg) -> - Ugeneric_apply(substitute fpc sb fn, - List.map (substitute fpc sb) args, dbg) + let dbg = subst_debuginfo loc dbg in + Ugeneric_apply(substitute loc fpc sb fn, + List.map (substitute loc fpc sb) args, dbg) | Uclosure(defs, env) -> (* Question: should we rename function labels as well? Otherwise, there is a risk that function labels are not globally unique. @@ -527,12 +544,12 @@ let rec substitute fpc sb ulam = - When we substitute offsets for idents bound by let rec in [close], case [Lletrec], we discard the original let rec body and use only the substituted term. *) - Uclosure(defs, List.map (substitute fpc sb) env) - | Uoffset(u, ofs) -> Uoffset(substitute fpc sb u, ofs) - | Ulet(id, u1, u2) -> + Uclosure(defs, List.map (substitute loc fpc sb) env) + | Uoffset(u, ofs) -> Uoffset(substitute loc fpc sb u, ofs) + | Ulet(str, kind, id, u1, u2) -> let id' = Ident.rename id in - Ulet(id', substitute fpc sb u1, - substitute fpc (Tbl.add id (Uvar id') sb) u2) + Ulet(str, kind, id', substitute loc fpc sb u1, + substitute loc fpc (Tbl.add id (Uvar id') sb) u2) | Uletrec(bindings, body) -> let bindings1 = List.map (fun (id, rhs) -> (id, Ident.rename id, rhs)) bindings in @@ -542,17 +559,17 @@ let rec substitute fpc sb ulam = bindings1 sb in Uletrec( List.map - (fun (id, id', rhs) -> (id', substitute fpc sb' rhs)) + (fun (_id, id', rhs) -> (id', substitute loc fpc sb' rhs)) bindings1, - substitute fpc sb' body) + substitute loc fpc sb' body) | Uprim(p, args, dbg) -> - let sargs = - List.map (substitute fpc sb) args in + let sargs = List.map (substitute loc fpc sb) args in + let dbg = subst_debuginfo loc dbg in let (res, _) = simplif_prim fpc p (sargs, List.map approx_ulam sargs) dbg in res | Uswitch(arg, sw) -> - let sarg = substitute fpc sb arg in + let sarg = substitute loc fpc sb arg in let action = (* Unfortunately, we cannot easily deal with the case of a constructed block (makeblock) bound to a local @@ -568,23 +585,23 @@ let rec substitute fpc sb ulam = | _ -> None in begin match action with - | Some u -> substitute fpc sb u + | Some u -> substitute loc fpc sb u | None -> Uswitch(sarg, { sw with us_actions_consts = - Array.map (substitute fpc sb) sw.us_actions_consts; + Array.map (substitute loc fpc sb) sw.us_actions_consts; us_actions_blocks = - Array.map (substitute fpc sb) sw.us_actions_blocks; + Array.map (substitute loc fpc sb) sw.us_actions_blocks; }) end | Ustringswitch(arg,sw,d) -> Ustringswitch - (substitute fpc sb arg, - List.map (fun (s,act) -> s,substitute fpc sb act) sw, - Misc.may_map (substitute fpc sb) d) + (substitute loc fpc sb arg, + List.map (fun (s,act) -> s,substitute loc fpc sb act) sw, + Misc.may_map (substitute loc fpc sb) d) | Ustaticfail (nfail, args) -> - Ustaticfail (nfail, List.map (substitute fpc sb) args) + Ustaticfail (nfail, List.map (substitute loc fpc sb) args) | Ucatch(nfail, ids, u1, u2) -> let ids' = List.map Ident.rename ids in let sb' = @@ -592,38 +609,39 @@ let rec substitute fpc sb ulam = (fun id id' s -> Tbl.add id (Uvar id') s) ids ids' sb in - Ucatch(nfail, ids', substitute fpc sb u1, substitute fpc sb' u2) + Ucatch(nfail, ids', substitute loc fpc sb u1, substitute loc fpc sb' u2) | Utrywith(u1, id, u2) -> let id' = Ident.rename id in - Utrywith(substitute fpc sb u1, id', - substitute fpc (Tbl.add id (Uvar id') sb) u2) + Utrywith(substitute loc fpc sb u1, id', + substitute loc fpc (Tbl.add id (Uvar id') sb) u2) | Uifthenelse(u1, u2, u3) -> - begin match substitute fpc sb u1 with + begin match substitute loc fpc sb u1 with Uconst (Uconst_ptr n) -> - if n <> 0 then substitute fpc sb u2 else substitute fpc sb u3 + if n <> 0 then substitute loc fpc sb u2 else substitute loc fpc sb u3 | Uprim(Pmakeblock _, _, _) -> - substitute fpc sb u2 + substitute loc fpc sb u2 | su1 -> - Uifthenelse(su1, substitute fpc sb u2, substitute fpc sb u3) + Uifthenelse(su1, substitute loc fpc sb u2, substitute loc fpc sb u3) end | Usequence(u1, u2) -> - Usequence(substitute fpc sb u1, substitute fpc sb u2) + Usequence(substitute loc fpc sb u1, substitute loc fpc sb u2) | Uwhile(u1, u2) -> - Uwhile(substitute fpc sb u1, substitute fpc sb u2) + Uwhile(substitute loc fpc sb u1, substitute loc fpc sb u2) | Ufor(id, u1, u2, dir, u3) -> let id' = Ident.rename id in - Ufor(id', substitute fpc sb u1, substitute fpc sb u2, dir, - substitute fpc (Tbl.add id (Uvar id') sb) u3) + Ufor(id', substitute loc fpc sb u1, substitute loc fpc sb u2, dir, + substitute loc fpc (Tbl.add id (Uvar id') sb) u3) | Uassign(id, u) -> let id' = try match Tbl.find id sb with Uvar i -> i | _ -> assert false with Not_found -> id in - Uassign(id', substitute fpc sb u) + Uassign(id', substitute loc fpc sb u) | Usend(k, u1, u2, ul, dbg) -> - Usend(k, substitute fpc sb u1, substitute fpc sb u2, - List.map (substitute fpc sb) ul, dbg) + let dbg = subst_debuginfo loc dbg in + Usend(k, substitute loc fpc sb u1, substitute loc fpc sb u2, + List.map (substitute loc fpc sb) ul, dbg) | Uunreachable -> Uunreachable @@ -637,50 +655,51 @@ let no_effects = function | Uclosure _ -> true | u -> is_simple_argument u -let rec bind_params_rec fpc subst params args body = +let rec bind_params_rec loc fpc subst params args body = match (params, args) with - ([], []) -> substitute fpc subst body + ([], []) -> substitute loc fpc subst body | (p1 :: pl, a1 :: al) -> if is_simple_argument a1 then - bind_params_rec fpc (Tbl.add p1 a1 subst) pl al body + bind_params_rec loc fpc (Tbl.add p1 a1 subst) pl al body else begin let p1' = Ident.rename p1 in let u1, u2 = match Ident.name p1, a1 with - | "*opt*", Uprim(Pmakeblock(0, Immutable), [a], dbg) -> - a, Uprim(Pmakeblock(0, Immutable), [Uvar p1'], dbg) + | "*opt*", Uprim(Pmakeblock(0, Immutable, kind), [a], dbg) -> + a, Uprim(Pmakeblock(0, Immutable, kind), [Uvar p1'], dbg) | _ -> a1, Uvar p1' in let body' = - bind_params_rec fpc (Tbl.add p1 u2 subst) pl al body in - if occurs_var p1 body then Ulet(p1', u1, body') + bind_params_rec loc fpc (Tbl.add p1 u2 subst) pl al body in + if occurs_var p1 body then Ulet(Immutable, Pgenval, p1', u1, body') else if no_effects a1 then body' else Usequence(a1, body') end | (_, _) -> assert false -let bind_params fpc params args body = +let bind_params loc fpc params args body = (* Reverse parameters and arguments to preserve right-to-left evaluation order (PR#2910). *) - bind_params_rec fpc Tbl.empty (List.rev params) (List.rev args) body + bind_params_rec loc fpc Tbl.empty (List.rev params) (List.rev args) body (* Check if a lambda term is ``pure'', that is without side-effects *and* not containing function definitions *) let rec is_pure = function - Lvar v -> true - | Lconst cst -> true + Lvar _ -> true + | Lconst _ -> true | Lprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ | - Pccall _ | Praise _ | Poffsetref _ | Pstringsetu | Pstringsets | - Parraysetu _ | Parraysets _ | Pbigarrayset _), _) -> false - | Lprim(p, args) -> List.for_all is_pure args - | Levent(lam, ev) -> is_pure lam + Pccall _ | Praise _ | Poffsetref _ | Pbytessetu | Pbytessets | + Parraysetu _ | Parraysets _ | Pbigarrayset _), _,_) -> false + | Lprim(_, args,_) -> List.for_all is_pure args + | Levent(lam, _ev) -> is_pure lam | _ -> false let warning_if_forced_inline ~loc ~attribute warning = if attribute = Always_inline then - Location.prerr_warning loc (Warnings.Inlining_impossible warning) + Location.prerr_warning loc + (Warnings.Inlining_impossible warning) (* Generate a direct application *) @@ -690,11 +709,12 @@ let direct_apply fundesc funct ufunct uargs ~loc ~attribute = let app = match fundesc.fun_inline, attribute with | _, Never_inline | None, _ -> + let dbg = Debuginfo.from_location loc in warning_if_forced_inline ~loc ~attribute "Function information unavailable"; - Udirect_apply(fundesc.fun_label, app_args, Debuginfo.none) + Udirect_apply(fundesc.fun_label, app_args, dbg) | Some(params, body), _ -> - bind_params fundesc.fun_float_const_prop params app_args body + bind_params loc fundesc.fun_float_const_prop params app_args body in (* If ufunct can contain side-effects or function definitions, we must make sure that it is evaluated exactly once. @@ -746,32 +766,6 @@ let global_approx = ref([||] : value_approximation array) let function_nesting_depth = ref 0 let excessive_function_nesting_depth = 5 -(* Decorate clambda term with debug information *) - -let rec add_debug_info ev u = - match ev.lev_kind with - | Lev_after _ -> - begin match u with - | Udirect_apply(lbl, args, dinfo) -> - Udirect_apply(lbl, args, Debuginfo.from_call ev) - | Ugeneric_apply(Udirect_apply(lbl, args1, dinfo1), - args2, dinfo2) -> - Ugeneric_apply(Udirect_apply(lbl, args1, Debuginfo.from_call ev), - args2, Debuginfo.from_call ev) - | Ugeneric_apply(fn, args, dinfo) -> - Ugeneric_apply(fn, args, Debuginfo.from_call ev) - | Uprim(Praise k, args, dinfo) -> - Uprim(Praise k, args, Debuginfo.from_call ev) - | Uprim(p, args, dinfo) -> - Uprim(p, args, Debuginfo.from_call ev) - | Usend(kind, u1, u2, args, dinfo) -> - Usend(kind, u1, u2, args, Debuginfo.from_call ev) - | Usequence(u1, u2) -> - Usequence(u1, add_debug_info ev u2) - | _ -> u - end - | _ -> u - (* Uncurry an expression and explicitate closures. Also return the approximation of the expression. The approximation environment [fenv] maps idents to approximations. @@ -790,7 +784,7 @@ let close_approx_var fenv cenv id = (subst, approx) let close_var fenv cenv id = - let (ulam, app) = close_approx_var fenv cenv id in ulam + let (ulam, _app) = close_approx_var fenv cenv id in ulam let rec close fenv cenv = function Lvar id -> @@ -814,16 +808,20 @@ let rec close fenv cenv = function | Const_immstring s -> str (Uconst_string s) | Const_base (Const_string (s, _)) -> - (* strings (even literal ones) are mutable! *) - (* of course, the empty string is really immutable *) - str ~shared:false(*(String.length s = 0)*) (Uconst_string s) + (* Strings (even literal ones) must be assumed to be mutable... + except when OCaml has been configured with + -safe-string. Passing -safe-string at compilation + time is not enough, since the unit could be linked + with another one compiled without -safe-string, and + that one could modify our string literal. *) + str ~shared:Config.safe_string (Uconst_string s) | Const_base(Const_float x) -> str (Uconst_float (float_of_string x)) | Const_base(Const_int32 x) -> str (Uconst_int32 x) | Const_base(Const_int64 x) -> str (Uconst_int64 x) | Const_base(Const_nativeint x) -> str (Uconst_nativeint x) in make_const (transl cst) - | Lfunction{kind; params; body} as funct -> + | Lfunction _ as funct -> close_one_function fenv cenv (Ident.create "fun") funct (* We convert [f a] to [let a' = a in fun b c -> f a' b c] @@ -833,16 +831,18 @@ let rec close fenv cenv = function let nargs = List.length args in begin match (close fenv cenv funct, close_list fenv cenv args) with ((ufunct, Value_closure(fundesc, approx_res)), - [Uprim(Pmakeblock(_, _), uargs, _)]) + [Uprim(Pmakeblock _, uargs, _)]) when List.length uargs = - fundesc.fun_arity -> - let app = direct_apply ~loc ~attribute fundesc funct ufunct uargs in + let app = + direct_apply ~loc ~attribute fundesc funct ufunct uargs in (app, strengthen_approx app approx_res) | ((ufunct, Value_closure(fundesc, approx_res)), uargs) when nargs = fundesc.fun_arity -> - let app = direct_apply ~loc ~attribute fundesc funct ufunct uargs in + let app = + direct_apply ~loc ~attribute fundesc funct ufunct uargs in (app, strengthen_approx app approx_res) - | ((ufunct, Value_closure(fundesc, approx_res)), uargs) + | ((_ufunct, Value_closure(fundesc, _approx_res)), uargs) when nargs < fundesc.fun_arity -> let first_args = List.map (fun arg -> (Ident.create "arg", arg) ) uargs in @@ -854,10 +854,10 @@ let rec close fenv cenv = function [] -> body | (arg1, arg2) :: args -> iter args - (Ulet ( arg1, arg2, body)) + (Ulet (Immutable, Pgenval, arg1, arg2, body)) in let internal_args = - (List.map (fun (arg1, arg2) -> Lvar arg1) first_args) + (List.map (fun (arg1, _arg2) -> Lvar arg1) first_args) @ (List.map (fun arg -> Lvar arg ) final_args) in let (new_fun, approx) = close fenv cenv @@ -870,44 +870,49 @@ let rec close fenv cenv = function ap_args=internal_args; ap_inlined=Default_inline; ap_specialised=Default_specialise}; + loc; attr = default_function_attribute}) in let new_fun = iter first_args new_fun in warning_if_forced_inline ~loc ~attribute "Partial application"; (new_fun, approx) - | ((ufunct, Value_closure(fundesc, approx_res)), uargs) + | ((ufunct, Value_closure(fundesc, _approx_res)), uargs) when fundesc.fun_arity > 0 && nargs > fundesc.fun_arity -> let (first_args, rem_args) = split_list fundesc.fun_arity uargs in + let dbg = Debuginfo.from_location loc in warning_if_forced_inline ~loc ~attribute "Over-application"; - (Ugeneric_apply(direct_apply ~loc ~attribute fundesc funct ufunct - first_args, rem_args, Debuginfo.none), + (Ugeneric_apply(direct_apply ~loc ~attribute + fundesc funct ufunct first_args, + rem_args, dbg), Value_unknown) | ((ufunct, _), uargs) -> + let dbg = Debuginfo.from_location loc in warning_if_forced_inline ~loc ~attribute "Unknown function"; - (Ugeneric_apply(ufunct, uargs, Debuginfo.none), Value_unknown) + (Ugeneric_apply(ufunct, uargs, dbg), Value_unknown) end - | Lsend(kind, met, obj, args, _) -> + | Lsend(kind, met, obj, args, loc) -> let (umet, _) = close fenv cenv met in let (uobj, _) = close fenv cenv obj in - (Usend(kind, umet, uobj, close_list fenv cenv args, Debuginfo.none), + let dbg = Debuginfo.from_location loc in + (Usend(kind, umet, uobj, close_list fenv cenv args, dbg), Value_unknown) - | Llet(str, id, lam, body) -> + | Llet(str, kind, id, lam, body) -> let (ulam, alam) = close_named fenv cenv id lam in begin match (str, alam) with (Variable, _) -> let (ubody, abody) = close fenv cenv body in - (Ulet(id, ulam, ubody), abody) + (Ulet(Mutable, kind, id, ulam, ubody), abody) | (_, Value_const _) when str = Alias || is_pure lam -> close (Tbl.add id alam fenv) cenv body | (_, _) -> let (ubody, abody) = close (Tbl.add id alam fenv) cenv body in - (Ulet(id, ulam, ubody), abody) + (Ulet(Immutable, kind, id, ulam, ubody), abody) end | Lletrec(defs, body) -> if List.for_all - (function (id, Lfunction _) -> true | _ -> false) + (function (_id, Lfunction _) -> true | _ -> false) defs then begin (* Simple case: only function definitions *) @@ -915,15 +920,16 @@ let rec close fenv cenv = function let clos_ident = Ident.create "clos" in let fenv_body = List.fold_right - (fun (id, pos, approx) fenv -> Tbl.add id approx fenv) + (fun (id, _pos, approx) fenv -> Tbl.add id approx fenv) infos fenv in let (ubody, approx) = close fenv_body cenv body in let sb = List.fold_right - (fun (id, pos, approx) sb -> + (fun (id, pos, _approx) sb -> Tbl.add id (Uoffset(Uvar clos_ident, pos)) sb) infos Tbl.empty in - (Ulet(clos_ident, clos, substitute !Clflags.float_const_prop sb ubody), + (Ulet(Immutable, Pgenval, clos_ident, clos, + substitute Location.none !Clflags.float_const_prop sb ubody), approx) end else begin (* General case: recursive definition of values *) @@ -937,42 +943,47 @@ let rec close fenv cenv = function let (ubody, approx) = close fenv_body cenv body in (Uletrec(udefs, ubody), approx) end - | Lprim(Pdirapply loc,[funct;arg]) - | Lprim(Prevapply loc,[arg;funct]) -> + | Lprim(Pdirapply,[funct;arg], loc) + | Lprim(Prevapply,[arg;funct], loc) -> close fenv cenv (Lapply{ap_should_be_tailcall=false; ap_loc=loc; ap_func=funct; ap_args=[arg]; ap_inlined=Default_inline; ap_specialised=Default_specialise}) - | Lprim(Pgetglobal id, []) as lam -> + | Lprim(Pgetglobal id, [], loc) as lam -> + let dbg = Debuginfo.from_location loc in check_constant_result lam - (getglobal id) + (getglobal dbg id) (Compilenv.global_approx id) - | Lprim(Pfield n, [lam]) -> + | Lprim(Pfield n, [lam], loc) -> let (ulam, approx) = close fenv cenv lam in - check_constant_result lam (Uprim(Pfield n, [ulam], Debuginfo.none)) + let dbg = Debuginfo.from_location loc in + check_constant_result lam (Uprim(Pfield n, [ulam], dbg)) (field_approx n approx) - | Lprim(Psetfield(n, is_ptr, init), [Lprim(Pgetglobal id, []); lam]) -> + | Lprim(Psetfield(n, is_ptr, init), [Lprim(Pgetglobal id, [], _); lam], loc)-> let (ulam, approx) = close fenv cenv lam in if approx <> Value_unknown then (!global_approx).(n) <- approx; - (Uprim(Psetfield(n, is_ptr, init), [getglobal id; ulam], Debuginfo.none), + let dbg = Debuginfo.from_location loc in + (Uprim(Psetfield(n, is_ptr, init), [getglobal dbg id; ulam], dbg), Value_unknown) - | Lprim(Praise k, [Levent(arg, ev)]) -> - let (ulam, approx) = close fenv cenv arg in - (Uprim(Praise k, [ulam], Debuginfo.from_raise ev), + | Lprim(Praise k, [arg], loc) -> + let (ulam, _approx) = close fenv cenv arg in + let dbg = Debuginfo.from_location loc in + (Uprim(Praise k, [ulam], dbg), Value_unknown) - | Lprim(p, args) -> + | Lprim(p, args, loc) -> + let dbg = Debuginfo.from_location loc in simplif_prim !Clflags.float_const_prop - p (close_list_approx fenv cenv args) Debuginfo.none + p (close_list_approx fenv cenv args) dbg | Lswitch(arg, sw) -> let fn fail = let (uarg, _) = close fenv cenv arg in let const_index, const_actions, fconst = - close_switch arg fenv cenv sw.sw_consts sw.sw_numconsts fail + close_switch fenv cenv sw.sw_consts sw.sw_numconsts fail and block_index, block_actions, fblock = - close_switch arg fenv cenv sw.sw_blocks sw.sw_numblocks fail in + close_switch fenv cenv sw.sw_blocks sw.sw_numblocks fail in let ulam = Uswitch (uarg, @@ -996,7 +1007,7 @@ let rec close fenv cenv = function Ucatch (i,[],ubody,uhandler),Value_unknown else fn fail end - | Lstringswitch(arg,sw,d) -> + | Lstringswitch(arg,sw,d,_) -> let uarg,_ = close fenv cenv arg in let usw = List.map @@ -1046,9 +1057,8 @@ let rec close fenv cenv = function | Lassign(id, lam) -> let (ulam, _) = close fenv cenv lam in (Uassign(id, ulam), Value_unknown) - | Levent(lam, ev) -> - let (ulam, approx) = close fenv cenv lam in - (add_debug_info ev ulam, approx) + | Levent(lam, _) -> + close fenv cenv lam | Lifused _ -> assert false @@ -1066,7 +1076,7 @@ and close_list_approx fenv cenv = function (ulam :: ulams, approx :: approxs) and close_named fenv cenv id = function - Lfunction{kind; params; body} as funct -> + Lfunction _ as funct -> close_one_function fenv cenv id funct | lam -> close fenv cenv lam @@ -1078,14 +1088,15 @@ and close_functions fenv cenv fun_defs = List.flatten (List.map (function - | (id, Lfunction{kind; params; body; attr}) -> - Simplif.split_default_wrapper id kind params body attr + | (id, Lfunction{kind; params; body; attr; loc}) -> + Simplif.split_default_wrapper ~id ~kind ~params + ~body ~attr ~wrapper_attr:attr ~loc () | _ -> assert false ) fun_defs) in let inline_attribute = match fun_defs with - | [_, Lfunction{kind; params; body; attr = { inline }}] -> inline + | [_, Lfunction{attr = { inline }}] -> inline | _ -> Default_inline (* recursive functions can't be inlined *) in @@ -1102,7 +1113,7 @@ and close_functions fenv cenv fun_defs = let uncurried_defs = List.map (function - (id, Lfunction{kind; params; body}) -> + (id, Lfunction{kind; params; body; loc}) -> let label = Compilenv.make_symbol (Some (Ident.unique_name id)) in let arity = List.length params in let fundesc = @@ -1111,20 +1122,21 @@ and close_functions fenv cenv fun_defs = fun_closed = initially_closed; fun_inline = None; fun_float_const_prop = !Clflags.float_const_prop } in - (id, params, body, fundesc) + let dbg = Debuginfo.from_location loc in + (id, params, body, fundesc, dbg) | (_, _) -> fatal_error "Closure.close_functions") fun_defs in (* Build an approximate fenv for compiling the functions *) let fenv_rec = List.fold_right - (fun (id, params, body, fundesc) fenv -> + (fun (id, _params, _body, fundesc, _dbg) fenv -> Tbl.add id (Value_closure(fundesc, Value_unknown)) fenv) uncurried_defs fenv in (* Determine the offsets of each function's closure in the shared block *) let env_pos = ref (-1) in let clos_offsets = List.map - (fun (id, params, body, fundesc) -> + (fun (_id, _params, _body, fundesc, _dbg) -> let pos = !env_pos + 1 in env_pos := !env_pos + 1 + (if fundesc.fun_arity <> 1 then 3 else 2); pos) @@ -1134,16 +1146,13 @@ and close_functions fenv cenv fun_defs = does not use its environment parameter is invalidated. *) let useless_env = ref initially_closed in (* Translate each function definition *) - let clos_fundef (id, params, body, fundesc) env_pos = - let dbg = match body with - | Levent (_,({lev_kind=Lev_function} as ev)) -> Debuginfo.from_call ev - | _ -> Debuginfo.none in + let clos_fundef (id, params, body, fundesc, dbg) env_pos = let env_param = Ident.create "env" in let cenv_fv = build_closure_env env_param (fv_pos - env_pos) fv in let cenv_body = List.fold_right2 - (fun (id, params, body, fundesc) pos env -> + (fun (id, _params, _body, _fundesc, _dbg) pos env -> Tbl.add id (Uoffset(Uvar env_param, pos - env_pos)) env) uncurried_defs clos_offsets cenv_fv in let (ubody, approx) = close fenv_rec cenv_body body in @@ -1193,7 +1202,7 @@ and close_functions fenv cenv fun_defs = recompile *) Compilenv.backtrack snap; (* PR#6337 *) List.iter - (fun (id, params, body, fundesc) -> + (fun (_id, _params, _body, fundesc, _dbg) -> fundesc.fun_closed <- false; fundesc.fun_inline <- None; ) @@ -1221,7 +1230,7 @@ and close_one_function fenv cenv id funct = (* Close a switch *) -and close_switch arg fenv cenv cases num_keys default = +and close_switch fenv cenv cases num_keys default = let ncases = List.length cases in let index = Array.make num_keys 0 and store = Storer.mk_store () in @@ -1287,7 +1296,7 @@ let collect_exported_structured_constants a = | Uconst_ref (s, (Some c)) -> Compilenv.add_exported_constant s; structured_constant c - | Uconst_ref (s, None) -> assert false (* Cannot be generated *) + | Uconst_ref (_s, None) -> assert false (* Cannot be generated *) | Uconst_int _ | Uconst_ptr _ -> () and structured_constant = function | Uconst_block (_, ul) -> List.iter const ul @@ -1304,7 +1313,7 @@ let collect_exported_structured_constants a = List.iter (fun f -> ulam f.body) fl; List.iter ulam ul | Uoffset(u, _) -> ulam u - | Ulet (_, u1, u2) -> ulam u1; ulam u2 + | Ulet (_str, _kind, _, u1, u2) -> ulam u1; ulam u2 | Uletrec (l, u) -> List.iter (fun (_, u) -> ulam u) l; ulam u | Uprim (_, ul, _) -> List.iter ulam ul | Uswitch (u, sl) -> @@ -1339,7 +1348,7 @@ let intro size lam = let id = Compilenv.make_symbol None in global_approx := Array.init size (fun i -> Value_global_field (id, i)); Compilenv.set_global_approx(Value_tuple !global_approx); - let (ulam, approx) = close Tbl.empty Tbl.empty lam in + let (ulam, _approx) = close Tbl.empty Tbl.empty lam in let opaque = !Clflags.opaque || Env.is_imported_opaque (Compilenv.current_unit_name ()) diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml index 9243cb47..eb920b28 100644 --- a/asmcomp/cmm.ml +++ b/asmcomp/cmm.ml @@ -107,6 +107,16 @@ let swap_comparison = function | Clt -> Cgt | Cle -> Cge | Cgt -> Clt | Cge -> Cle +type label = int + +let label_counter = ref 99 + +let new_label() = incr label_counter; !label_counter + +type raise_kind = + | Raise_withtrace + | Raise_notrace + type memory_chunk = Byte_unsigned | Byte_signed @@ -120,11 +130,13 @@ type memory_chunk = | Double | Double_u -type operation = +and operation = Capply of machtype * Debuginfo.t - | Cextcall of string * machtype * bool * Debuginfo.t + | Cextcall of string * machtype * bool * Debuginfo.t * label option + (** If specified, the given label will be placed immediately after the + call (at the same place as any frame descriptor would reference). *) | Cload of memory_chunk - | Calloc + | Calloc of Debuginfo.t | Cstore of memory_chunk * Lambda.initialization_or_assignment | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi | Cand | Cor | Cxor | Clsl | Clsr | Casr @@ -135,7 +147,7 @@ type operation = | Caddf | Csubf | Cmulf | Cdivf | Cfloatofint | Cintoffloat | Ccmpf of comparison - | Craise of Lambda.raise_kind * Debuginfo.t + | Craise of raise_kind * Debuginfo.t | Ccheckbound of Debuginfo.t type expression = @@ -145,7 +157,7 @@ type expression = | Cconst_symbol of string | Cconst_pointer of int | Cconst_natpointer of nativeint - | Cconst_blockheader of nativeint + | Cblockheader of nativeint * Debuginfo.t | Cvar of Ident.t | Clet of Ident.t * expression * expression | Cassign of Ident.t * expression @@ -164,11 +176,11 @@ type fundecl = fun_args: (Ident.t * machtype) list; fun_body: expression; fun_fast: bool; - fun_dbg : Debuginfo.t; } + fun_dbg : Debuginfo.t; + } type data_item = Cdefine_symbol of string - | Cdefine_label of int | Cglobal_symbol of string | Cint8 of int | Cint16 of int @@ -177,7 +189,6 @@ type data_item = | Csingle of float | Cdouble of float | Csymbol_address of string - | Clabel_address of int | Cstring of string | Cskip of int | Calign of int @@ -185,3 +196,6 @@ type data_item = type phrase = Cfunction of fundecl | Cdata of data_item list + +let reset () = + label_counter := 99 diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli index 31c222cf..0b1a781e 100644 --- a/asmcomp/cmm.mli +++ b/asmcomp/cmm.mli @@ -83,6 +83,13 @@ type comparison = val negate_comparison: comparison -> comparison val swap_comparison: comparison -> comparison +type label = int +val new_label: unit -> label + +type raise_kind = + | Raise_withtrace + | Raise_notrace + type memory_chunk = Byte_unsigned | Byte_signed @@ -96,11 +103,11 @@ type memory_chunk = | Double (* 64-bit-aligned 64-bit float *) | Double_u (* word-aligned 64-bit float *) -type operation = +and operation = Capply of machtype * Debuginfo.t - | Cextcall of string * machtype * bool * Debuginfo.t + | Cextcall of string * machtype * bool * Debuginfo.t * label option | Cload of memory_chunk - | Calloc + | Calloc of Debuginfo.t | Cstore of memory_chunk * Lambda.initialization_or_assignment | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi | Cand | Cor | Cxor | Clsl | Clsr | Casr @@ -112,17 +119,17 @@ type operation = | Caddf | Csubf | Cmulf | Cdivf | Cfloatofint | Cintoffloat | Ccmpf of comparison - | Craise of Lambda.raise_kind * Debuginfo.t + | Craise of raise_kind * Debuginfo.t | Ccheckbound of Debuginfo.t -type expression = +and expression = Cconst_int of int | Cconst_natint of nativeint | Cconst_float of float | Cconst_symbol of string | Cconst_pointer of int | Cconst_natpointer of nativeint - | Cconst_blockheader of nativeint + | Cblockheader of nativeint * Debuginfo.t | Cvar of Ident.t | Clet of Ident.t * expression * expression | Cassign of Ident.t * expression @@ -141,11 +148,11 @@ type fundecl = fun_args: (Ident.t * machtype) list; fun_body: expression; fun_fast: bool; - fun_dbg : Debuginfo.t; } + fun_dbg : Debuginfo.t; + } type data_item = Cdefine_symbol of string - | Cdefine_label of int | Cglobal_symbol of string | Cint8 of int | Cint16 of int @@ -154,7 +161,6 @@ type data_item = | Csingle of float | Cdouble of float | Csymbol_address of string - | Clabel_address of int | Cstring of string | Cskip of int | Calign of int @@ -162,3 +168,5 @@ type data_item = type phrase = Cfunction of fundecl | Cdata of data_item list + +val reset : unit -> unit diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 78a39ddb..fd21651f 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -31,7 +31,7 @@ let bind name arg fn = match arg with Cvar _ | Cconst_int _ | Cconst_natint _ | Cconst_symbol _ | Cconst_pointer _ | Cconst_natpointer _ - | Cconst_blockheader _ -> fn arg + | Cblockheader _ -> fn arg | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id)) let bind_load name arg fn = @@ -43,7 +43,7 @@ let bind_nonvar name arg fn = match arg with Cconst_int _ | Cconst_natint _ | Cconst_symbol _ | Cconst_pointer _ | Cconst_natpointer _ - | Cconst_blockheader _ -> fn arg + | Cblockheader _ -> fn arg | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id)) let caml_black = Nativeint.shift_left (Nativeint.of_int 3) 8 @@ -72,13 +72,13 @@ let boxedint32_header = block_header Obj.custom_tag 2 let boxedint64_header = block_header Obj.custom_tag (1 + 8 / size_addr) let boxedintnat_header = block_header Obj.custom_tag 2 -let alloc_float_header = Cconst_blockheader(float_header) -let alloc_floatarray_header len = Cconst_blockheader(floatarray_header len) -let alloc_closure_header sz = Cconst_blockheader(white_closure_header sz) -let alloc_infix_header ofs = Cconst_blockheader(infix_header ofs) -let alloc_boxedint32_header = Cconst_blockheader(boxedint32_header) -let alloc_boxedint64_header = Cconst_blockheader(boxedint64_header) -let alloc_boxedintnat_header = Cconst_blockheader(boxedintnat_header) +let alloc_float_header dbg = Cblockheader(float_header, dbg) +let alloc_floatarray_header len dbg = Cblockheader(floatarray_header len, dbg) +let alloc_closure_header sz dbg = Cblockheader(white_closure_header sz, dbg) +let alloc_infix_header ofs dbg = Cblockheader(infix_header ofs, dbg) +let alloc_boxedint32_header dbg = Cblockheader(boxedint32_header, dbg) +let alloc_boxedint64_header dbg = Cblockheader(boxedint64_header, dbg) +let alloc_boxedintnat_header dbg = Cblockheader(boxedintnat_header, dbg) (* Integers *) @@ -156,7 +156,7 @@ and mult_power2 c n = lsl_int c (Cconst_int (Misc.log2 n)) let rec mul_int c1 c2 = match (c1, c2) with - | (c, Cconst_int 0) | (Cconst_int 0, c) -> + | (_, Cconst_int 0) | (Cconst_int 0, _) -> Cconst_int 0 | (c, Cconst_int 1) | (Cconst_int 1, c) -> c @@ -320,11 +320,19 @@ let validate d m p = ucompare2 twoszp md < 0 && ucompare2 md (add2 twoszp twop1) <= 0 *) -let rec div_int c1 c2 dbg = +let raise_regular dbg exc = + Csequence( + Cop(Cstore (Thirtytwo_signed, Assignment), + [(Cconst_symbol "caml_backtrace_pos"); Cconst_int 0]), + Cop(Craise (Raise_withtrace, dbg),[exc])) + +let raise_symbol dbg symb = + raise_regular dbg (Cconst_symbol symb) + +let rec div_int c1 c2 is_safe dbg = match (c1, c2) with (c1, Cconst_int 0) -> - Csequence(c1, Cop(Craise (Raise_regular, dbg), - [Cconst_symbol "caml_exn_Division_by_zero"])) + Csequence(c1, raise_symbol dbg "caml_exn_Division_by_zero") | (c1, Cconst_int 1) -> c1 | (Cconst_int 0 as c1, c2) -> @@ -346,7 +354,7 @@ let rec div_int c1 c2 dbg = add_int c1 t); Cconst_int l]) else if n < 0 then - sub_int (Cconst_int 0) (div_int c1 (Cconst_int (-n)) dbg) + sub_int (Cconst_int 0) (div_int c1 (Cconst_int (-n)) is_safe dbg) else begin let (m, p) = divimm_parameters (Nativeint.of_int n) in (* Algorithm: @@ -361,20 +369,18 @@ let rec div_int c1 c2 dbg = let t = if p > 0 then Cop(Casr, [t; Cconst_int p]) else t in add_int t (lsr_int c1 (Cconst_int (Nativeint.size - 1)))) end - | (c1, c2) when !Clflags.fast -> + | (c1, c2) when !Clflags.fast || is_safe = Lambda.Unsafe -> Cop(Cdivi, [c1; c2]) | (c1, c2) -> bind "divisor" c2 (fun c2 -> Cifthenelse(c2, Cop(Cdivi, [c1; c2]), - Cop(Craise (Raise_regular, dbg), - [Cconst_symbol "caml_exn_Division_by_zero"]))) + raise_symbol dbg "caml_exn_Division_by_zero")) -let mod_int c1 c2 dbg = +let mod_int c1 c2 is_safe dbg = match (c1, c2) with (c1, Cconst_int 0) -> - Csequence(c1, Cop(Craise (Raise_regular, dbg), - [Cconst_symbol "caml_exn_Division_by_zero"])) + Csequence(c1, raise_symbol dbg "caml_exn_Division_by_zero") | (c1, Cconst_int (1 | (-1))) -> Csequence(c1, Cconst_int 0) | (Cconst_int 0, c2) -> @@ -399,15 +405,15 @@ let mod_int c1 c2 dbg = sub_int c1 t) else bind "dividend" c1 (fun c1 -> - sub_int c1 (mul_int (div_int c1 c2 dbg) c2)) - | (c1, c2) when !Clflags.fast -> + sub_int c1 (mul_int (div_int c1 c2 is_safe dbg) c2)) + | (c1, c2) when !Clflags.fast || is_safe = Lambda.Unsafe -> + (* Flambda already generates that test *) Cop(Cmodi, [c1; c2]) | (c1, c2) -> bind "divisor" c2 (fun c2 -> Cifthenelse(c2, Cop(Cmodi, [c1; c2]), - Cop(Craise (Raise_regular, dbg), - [Cconst_symbol "caml_exn_Division_by_zero"]))) + raise_symbol dbg "caml_exn_Division_by_zero")) (* Division or modulo on boxed integers. The overflow case min_int / -1 can occur, in which case we force x / -1 = -x and x mod -1 = 0. (PR#5513). *) @@ -417,21 +423,21 @@ let is_different_from x = function | Cconst_natint n -> n <> Nativeint.of_int x | _ -> false -let safe_divmod_bi mkop mkm1 c1 c2 bi dbg = +let safe_divmod_bi mkop is_safe mkm1 c1 c2 bi dbg = bind "dividend" c1 (fun c1 -> bind "divisor" c2 (fun c2 -> - let c = mkop c1 c2 dbg in + let c = mkop c1 c2 is_safe dbg in if Arch.division_crashes_on_overflow && (size_int = 4 || bi <> Pint32) && not (is_different_from (-1) c2) then Cifthenelse(Cop(Ccmpi Cne, [c2; Cconst_int(-1)]), c, mkm1 c1) else c)) -let safe_div_bi = - safe_divmod_bi div_int (fun c1 -> Cop(Csubi, [Cconst_int 0; c1])) +let safe_div_bi is_safe = + safe_divmod_bi div_int is_safe (fun c1 -> Cop(Csubi, [Cconst_int 0; c1])) -let safe_mod_bi = - safe_divmod_bi mod_int (fun c1 -> Cconst_int 0) +let safe_mod_bi is_safe = + safe_divmod_bi mod_int is_safe (fun _ -> Cconst_int 0) (* Bool *) @@ -446,10 +452,10 @@ let test_bool = function (* Float *) -let box_float c = Cop(Calloc, [alloc_float_header; c]) +let box_float dbg c = Cop(Calloc dbg, [alloc_float_header dbg; c]) let rec unbox_float = function - Cop(Calloc, [header; c]) -> c + Cop(Calloc _, [_header; c]) -> c | Clet(id, exp, body) -> Clet(id, exp, unbox_float body) | Cifthenelse(cond, e1, e2) -> Cifthenelse(cond, unbox_float e1, unbox_float e2) @@ -461,8 +467,8 @@ let rec unbox_float = function (* Complex *) -let box_complex c_re c_im = - Cop(Calloc, [alloc_floatarray_header 2; c_re; c_im]) +let box_complex dbg c_re c_im = + Cop(Calloc dbg, [alloc_floatarray_header 2 dbg; c_re; c_im]) let complex_re c = Cop(Cload Double_u, [c]) let complex_im c = Cop(Cload Double_u, @@ -487,10 +493,10 @@ let rec remove_unit = function Ctrywith(remove_unit body, exn, remove_unit handler) | Clet(id, c1, c2) -> Clet(id, c1, remove_unit c2) - | Cop(Capply (mty, dbg), args) -> + | Cop(Capply (_mty, dbg), args) -> Cop(Capply (typ_void, dbg), args) - | Cop(Cextcall(proc, mty, alloc, dbg), args) -> - Cop(Cextcall(proc, typ_void, alloc, dbg), args) + | Cop(Cextcall(proc, _mty, alloc, dbg, label_after), args) -> + Cop(Cextcall(proc, typ_void, alloc, dbg, label_after), args) | Cexit (_,_) as c -> c | Ctuple [] as c -> c | c -> Csequence(c, Ctuple []) @@ -510,7 +516,14 @@ let set_field ptr n newval init = Cop(Cstore (Word_val, init), [field_address ptr n; newval]) let header ptr = - Cop(Cload Word_int, [Cop(Cadda, [ptr; Cconst_int(-size_int)])]) + if Config.spacetime then + let non_profinfo_mask = (1 lsl (64 - Config.profinfo_width)) - 1 in + Cop(Cand, [Cop (Cload Word_int, + [Cop(Cadda, [ptr; Cconst_int(-size_int)])]); + Cconst_int non_profinfo_mask; + ]) + else + Cop(Cload Word_int, [Cop(Cadda, [ptr; Cconst_int(-size_int)])]) let tag_offset = if big_endian then -1 else -size_int @@ -583,11 +596,11 @@ let int_array_ref arr ofs = Cop(Cload Word_int, [array_indexing log2_size_addr arr ofs]) let unboxed_float_array_ref arr ofs = Cop(Cload Double_u, [array_indexing log2_size_float arr ofs]) -let float_array_ref arr ofs = - box_float(unboxed_float_array_ref arr ofs) +let float_array_ref dbg arr ofs = + box_float dbg (unboxed_float_array_ref arr ofs) let addr_array_set arr ofs newval = - Cop(Cextcall("caml_modify", typ_void, false, Debuginfo.none), + Cop(Cextcall("caml_modify", typ_void, false, Debuginfo.none, None), [array_indexing log2_size_addr arr ofs; newval]) let int_array_set arr ofs newval = Cop(Cstore (Word_int, Assignment), @@ -618,7 +631,8 @@ let string_length exp = let lookup_tag obj tag = bind "tag" tag (fun tag -> - Cop(Cextcall("caml_get_public_method", typ_val, false, Debuginfo.none), + Cop(Cextcall("caml_get_public_method", typ_val, false, Debuginfo.none, + None), [obj; tag])) let lookup_label obj lab = @@ -636,9 +650,9 @@ let call_cached_method obj tag cache pos args dbg = (* Allocation *) -let make_alloc_generic set_fn tag wordsize args = +let make_alloc_generic set_fn dbg tag wordsize args = if wordsize <= Config.max_young_wosize then - Cop(Calloc, Cconst_blockheader(block_header tag wordsize) :: args) + Cop(Calloc dbg, Cblockheader(block_header tag wordsize, dbg) :: args) else begin let id = Ident.create "alloc" in let rec fill_fields idx = function @@ -646,15 +660,15 @@ let make_alloc_generic set_fn tag wordsize args = | e1::el -> Csequence(set_fn (Cvar id) (Cconst_int idx) e1, fill_fields (idx + 2) el) in Clet(id, - Cop(Cextcall("caml_alloc", typ_val, true, Debuginfo.none), + Cop(Cextcall("caml_alloc", typ_val, true, Debuginfo.none, None), [Cconst_int wordsize; Cconst_int tag]), fill_fields 1 args) end -let make_alloc tag args = - make_alloc_generic addr_array_set tag (List.length args) args -let make_float_alloc tag args = - make_alloc_generic float_array_set tag +let make_alloc dbg tag args = + make_alloc_generic addr_array_set dbg tag (List.length args) args +let make_float_alloc dbg tag args = + make_alloc_generic float_array_set dbg tag (List.length args * size_float / size_addr) args (* Bounds checking *) @@ -695,11 +709,11 @@ let rec expr_size env = function begin try Ident.find_same id env with Not_found -> RHS_nonrec end | Uclosure(fundecls, clos_vars) -> RHS_block (fundecls_size fundecls + List.length clos_vars) - | Ulet(id, exp, body) -> + | Ulet(_str, _kind, id, exp, body) -> expr_size (Ident.add id (expr_size env exp) env) body - | Uletrec(bindings, body) -> + | Uletrec(_bindings, body) -> expr_size env body - | Uprim(Pmakeblock(tag, mut), args, _) -> + | Uprim(Pmakeblock _, args, _) -> RHS_block (List.length args) | Uprim(Pmakearray((Paddrarray | Pintarray), _), args, _) -> RHS_block (List.length args) @@ -707,6 +721,8 @@ let rec expr_size env = function RHS_floatblock (List.length args) | Uprim (Pduprecord ((Record_regular | Record_inlined _), sz), _, _) -> RHS_block sz + | Uprim (Pduprecord (Record_unboxed _, _), _, _) -> + assert false | Uprim (Pduprecord (Record_extension, sz), _, _) -> RHS_block (sz + 1) | Uprim (Pduprecord (Record_float, sz), _, _) -> @@ -715,7 +731,7 @@ let rec expr_size env = function when prim_name = "caml_check_value_is_closure" -> (* Used for "-clambda-checks". *) expr_size env closure - | Usequence(exp, exp') -> + | Usequence(_exp, exp') -> expr_size env exp' | _ -> RHS_nonrec @@ -783,7 +799,7 @@ let alloc_header_boxed_int bi = | Pint32 -> alloc_boxedint32_header | Pint64 -> alloc_boxedint64_header -let box_int bi arg = +let box_int dbg bi arg = match arg with Cconst_int n -> transl_structured_constant (box_int_constant bi (Nativeint.of_int n)) @@ -794,7 +810,7 @@ let box_int bi arg = if bi = Pint32 && size_int = 8 && big_endian then Cop(Clsl, [arg; Cconst_int 32]) else arg in - Cop(Calloc, [alloc_header_boxed_int bi; + Cop(Calloc dbg, [alloc_header_boxed_int bi dbg; Cconst_symbol(operations_boxed_int bi); arg']) @@ -807,15 +823,15 @@ let split_int64_for_32bit_target arg = let rec unbox_int bi arg = match arg with - Cop(Calloc, [hdr; ops; Cop(Clsl, [contents; Cconst_int 32])]) + Cop(Calloc _, [_hdr; _ops; Cop(Clsl, [contents; Cconst_int 32])]) when bi = Pint32 && size_int = 8 && big_endian -> (* Force sign-extension of low 32 bits *) Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32]); Cconst_int 32]) - | Cop(Calloc, [hdr; ops; contents]) + | Cop(Calloc _, [_hdr; _ops; contents]) when bi = Pint32 && size_int = 8 && not big_endian -> (* Force sign-extension of low 32 bits *) Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32]); Cconst_int 32]) - | Cop(Calloc, [hdr; ops; contents]) -> + | Cop(Calloc _, [_hdr; _ops; contents]) -> contents | Clet(id, exp, body) -> Clet(id, exp, unbox_int bi body) | Cifthenelse(cond, e1, e2) -> @@ -839,13 +855,27 @@ let make_unsigned_int bi arg = (* Boxed numbers *) type boxed_number = - | Boxed_float - | Boxed_integer of boxed_integer + | Boxed_float of Debuginfo.t + | Boxed_integer of boxed_integer * Debuginfo.t + +let equal_unboxed_integer ui1 ui2 = + match ui1, ui2 with + | Pnativeint, Pnativeint -> true + | Pint32, Pint32 -> true + | Pint64, Pint64 -> true + | _, _ -> false + +let equal_boxed_number bn1 bn2 = + match bn1, bn2 with + | Boxed_float _, Boxed_float _ -> true + | Boxed_integer(ui1, _), Boxed_integer(ui2, _) -> + equal_unboxed_integer ui1 ui2 + | _, _ -> false let box_number bn arg = match bn with - | Boxed_float -> box_float arg - | Boxed_integer bi -> box_int bi arg + | Boxed_float dbg -> box_float dbg arg + | Boxed_integer (bi, dbg) -> box_int dbg bi arg type env = { unboxed_ids : (Ident.t * boxed_number) Ident.tbl; @@ -954,7 +984,7 @@ let bigarray_get unsafe elt_kind layout b args dbg = let sz = bigarray_elt_size elt_kind / 2 in bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr -> - box_complex + box_complex dbg (Cop(Cload kind, [addr])) (Cop(Cload kind, [Cop(Cadda, [addr; Cconst_int sz])]))) | _ -> @@ -1162,8 +1192,8 @@ let simplif_primitive_32bits = function | Paddbint Pint64 -> Pccall (default_prim "caml_int64_add") | Psubbint Pint64 -> Pccall (default_prim "caml_int64_sub") | Pmulbint Pint64 -> Pccall (default_prim "caml_int64_mul") - | Pdivbint Pint64 -> Pccall (default_prim "caml_int64_div") - | Pmodbint Pint64 -> Pccall (default_prim "caml_int64_mod") + | Pdivbint {size=Pint64} -> Pccall (default_prim "caml_int64_div") + | Pmodbint {size=Pint64} -> Pccall (default_prim "caml_int64_mod") | Pandbint Pint64 -> Pccall (default_prim "caml_int64_and") | Porbint Pint64 -> Pccall (default_prim "caml_int64_or") | Pxorbint Pint64 -> Pccall (default_prim "caml_int64_xor") @@ -1176,9 +1206,9 @@ let simplif_primitive_32bits = function | Pbintcomp(Pint64, Lambda.Cgt) -> Pccall (default_prim "caml_greaterthan") | Pbintcomp(Pint64, Lambda.Cle) -> Pccall (default_prim "caml_lessequal") | Pbintcomp(Pint64, Lambda.Cge) -> Pccall (default_prim "caml_greaterequal") - | Pbigarrayref(unsafe, n, Pbigarray_int64, layout) -> + | Pbigarrayref(_unsafe, n, Pbigarray_int64, _layout) -> Pccall (default_prim ("caml_ba_get_" ^ string_of_int n)) - | Pbigarrayset(unsafe, n, Pbigarray_int64, layout) -> + | Pbigarrayset(_unsafe, n, Pbigarray_int64, _layout) -> Pccall (default_prim ("caml_ba_set_" ^ string_of_int n)) | Pstring_load_64(_) -> Pccall (default_prim "caml_string_get64") | Pstring_set_64(_) -> Pccall (default_prim "caml_string_set64") @@ -1191,13 +1221,13 @@ let simplif_primitive p = match p with | Pduprecord _ -> Pccall (default_prim "caml_obj_dup") - | Pbigarrayref(unsafe, n, Pbigarray_unknown, layout) -> + | Pbigarrayref(_unsafe, n, Pbigarray_unknown, _layout) -> Pccall (default_prim ("caml_ba_get_" ^ string_of_int n)) - | Pbigarrayset(unsafe, n, Pbigarray_unknown, layout) -> + | Pbigarrayset(_unsafe, n, Pbigarray_unknown, _layout) -> Pccall (default_prim ("caml_ba_set_" ^ string_of_int n)) - | Pbigarrayref(unsafe, n, kind, Pbigarray_unknown_layout) -> + | Pbigarrayref(_unsafe, n, _kind, Pbigarray_unknown_layout) -> Pccall (default_prim ("caml_ba_get_" ^ string_of_int n)) - | Pbigarrayset(unsafe, n, kind, Pbigarray_unknown_layout) -> + | Pbigarrayset(_unsafe, n, _kind, Pbigarray_unknown_layout) -> Pccall (default_prim ("caml_ba_set_" ^ string_of_int n)) | p -> if size_int = 8 then p else simplif_primitive_32bits p @@ -1317,83 +1347,97 @@ let transl_int_switch arg low high cases default = match cases with type unboxed_number_kind = No_unboxing - | Boxed of boxed_number + | Boxed of boxed_number * bool (* true: boxed form available at no cost *) | No_result (* expression never returns a result *) -let unboxed_number_kind_of_unbox = function +let unboxed_number_kind_of_unbox dbg = function | Same_as_ocaml_repr -> No_unboxing - | Unboxed_float -> Boxed Boxed_float - | Unboxed_integer bi -> Boxed (Boxed_integer bi) + | Unboxed_float -> Boxed (Boxed_float dbg, false) + | Unboxed_integer bi -> Boxed (Boxed_integer (bi, dbg), false) | Untagged_int -> No_unboxing -let rec is_unboxed_number env e = +let rec is_unboxed_number ~strict env e = (* Given unboxed_number_kind from two branches of the code, returns the - resulting unboxed_number_kind *) + resulting unboxed_number_kind. + + If [strict=false], one knows that the type of the expression + is an unboxable number, and we decide to return an unboxed value + if this indeed eliminates at least one allocation. + + If [strict=true], we need to ensure that all possible branches + return an unboxable number (of the same kind). This could not + be the case in presence of GADTs. + *) let join k1 e = - match k1, is_unboxed_number env e with - | Boxed b1, Boxed b2 when b1 = b2 -> Boxed b1 + match k1, is_unboxed_number ~strict env e with + | Boxed (b1, c1), Boxed (b2, c2) when equal_boxed_number b1 b2 -> + Boxed (b1, c1 && c2) | No_result, k | k, No_result -> k (* if a branch never returns, it is safe to unbox it *) + | No_unboxing, k | k, No_unboxing when not strict -> + k | _, _ -> No_unboxing in match e with | Uvar id -> begin match is_unboxed_id id env with | None -> No_unboxing - | Some (_, bn) -> Boxed bn + | Some (_, bn) -> Boxed (bn, false) end | Uconst(Uconst_ref(_, Some (Uconst_float _))) -> - Boxed Boxed_float + Boxed (Boxed_float Debuginfo.none, true) | Uconst(Uconst_ref(_, Some (Uconst_int32 _))) -> - Boxed (Boxed_integer Pint32) + Boxed (Boxed_integer (Pint32, Debuginfo.none), true) | Uconst(Uconst_ref(_, Some (Uconst_int64 _))) -> - Boxed (Boxed_integer Pint64) + Boxed (Boxed_integer (Pint64, Debuginfo.none), true) | Uconst(Uconst_ref(_, Some (Uconst_nativeint _))) -> - Boxed (Boxed_integer Pnativeint) - | Uprim(p, _, _) -> + Boxed (Boxed_integer (Pnativeint, Debuginfo.none), true) + | Uprim(p, _, dbg) -> begin match simplif_primitive p with - | Pccall p -> unboxed_number_kind_of_unbox p.prim_native_repr_res - | Pfloatfield _ -> Boxed Boxed_float - | Pfloatofint -> Boxed Boxed_float - | Pnegfloat -> Boxed Boxed_float - | Pabsfloat -> Boxed Boxed_float - | Paddfloat -> Boxed Boxed_float - | Psubfloat -> Boxed Boxed_float - | Pmulfloat -> Boxed Boxed_float - | Pdivfloat -> Boxed Boxed_float - | Parrayrefu Pfloatarray -> Boxed Boxed_float - | Parrayrefs Pfloatarray -> Boxed Boxed_float - | Pbintofint bi -> Boxed (Boxed_integer bi) - | Pcvtbint(src, dst) -> Boxed (Boxed_integer dst) - | Pnegbint bi -> Boxed (Boxed_integer bi) - | Paddbint bi -> Boxed (Boxed_integer bi) - | Psubbint bi -> Boxed (Boxed_integer bi) - | Pmulbint bi -> Boxed (Boxed_integer bi) - | Pdivbint bi -> Boxed (Boxed_integer bi) - | Pmodbint bi -> Boxed (Boxed_integer bi) - | Pandbint bi -> Boxed (Boxed_integer bi) - | Porbint bi -> Boxed (Boxed_integer bi) - | Pxorbint bi -> Boxed (Boxed_integer bi) - | Plslbint bi -> Boxed (Boxed_integer bi) - | Plsrbint bi -> Boxed (Boxed_integer bi) - | Pasrbint bi -> Boxed (Boxed_integer bi) + | Pccall p -> unboxed_number_kind_of_unbox dbg p.prim_native_repr_res + | Pfloatfield _ + | Pfloatofint + | Pnegfloat + | Pabsfloat + | Paddfloat + | Psubfloat + | Pmulfloat + | Pdivfloat + | Parrayrefu Pfloatarray + | Parrayrefs Pfloatarray -> Boxed (Boxed_float dbg, false) + | Pbintofint bi + | Pcvtbint(_, bi) + | Pnegbint bi + | Paddbint bi + | Psubbint bi + | Pmulbint bi + | Pdivbint {size=bi} + | Pmodbint {size=bi} + | Pandbint bi + | Porbint bi + | Pxorbint bi + | Plslbint bi + | Plsrbint bi + | Pasrbint bi + | Pbbswap bi -> Boxed (Boxed_integer (bi, dbg), false) | Pbigarrayref(_, _, (Pbigarray_float32 | Pbigarray_float64), _) -> - Boxed Boxed_float - | Pbigarrayref(_, _, Pbigarray_int32, _) -> Boxed (Boxed_integer Pint32) - | Pbigarrayref(_, _, Pbigarray_int64, _) -> Boxed (Boxed_integer Pint64) + Boxed (Boxed_float dbg, false) + | Pbigarrayref(_, _, Pbigarray_int32, _) -> + Boxed (Boxed_integer (Pint32, dbg), false) + | Pbigarrayref(_, _, Pbigarray_int64, _) -> + Boxed (Boxed_integer (Pint64, dbg), false) | Pbigarrayref(_, _, Pbigarray_native_int,_) -> - Boxed (Boxed_integer Pnativeint) - | Pstring_load_32(_) -> Boxed (Boxed_integer Pint32) - | Pstring_load_64(_) -> Boxed (Boxed_integer Pint64) - | Pbigstring_load_32(_) -> Boxed (Boxed_integer Pint32) - | Pbigstring_load_64(_) -> Boxed (Boxed_integer Pint64) - | Pbbswap bi -> Boxed (Boxed_integer bi) + Boxed (Boxed_integer (Pnativeint, dbg), false) + | Pstring_load_32(_) -> Boxed (Boxed_integer (Pint32, dbg), false) + | Pstring_load_64(_) -> Boxed (Boxed_integer (Pint64, dbg), false) + | Pbigstring_load_32(_) -> Boxed (Boxed_integer (Pint32, dbg), false) + | Pbigstring_load_64(_) -> Boxed (Boxed_integer (Pint64, dbg), false) | Praise _ -> No_result | _ -> No_unboxing end - | Ulet (_, _, e) | Uletrec (_, e) | Usequence (_, e) -> - is_unboxed_number env e + | Ulet (_, _, _, _, e) | Uletrec (_, e) | Usequence (_, e) -> + is_unboxed_number ~strict env e | Uswitch (_, switch) -> let k = Array.fold_left join No_result switch.us_actions_consts in Array.fold_left join k switch.us_actions_blocks @@ -1405,7 +1449,7 @@ let rec is_unboxed_number env e = end | Ustaticfail _ -> No_result | Uifthenelse (_, e1, e2) | Ucatch (_, _, e1, e2) | Utrywith (e1, _, e2) -> - join (is_unboxed_number env e1) e2 + join (is_unboxed_number ~strict env e1) e2 | _ -> No_unboxing (* Translate an expression *) @@ -1446,8 +1490,8 @@ let rec transl env e = Queue.add f functions; let header = if pos = 0 - then alloc_closure_header block_size - else alloc_infix_header pos in + then alloc_closure_header block_size f.dbg + else alloc_infix_header pos f.dbg in if f.arity = 1 || f.arity = 0 then header :: Cconst_symbol f.label :: @@ -1459,7 +1503,7 @@ let rec transl env e = int_const f.arity :: Cconst_symbol f.label :: transl_fundecls (pos + 4) rem in - Cop(Calloc, transl_fundecls 0 fundecls) + Cop(Calloc Debuginfo.none, transl_fundecls 0 fundecls) | Uoffset(arg, offset) -> (* produces a valid Caml value, pointing just after an infix header *) let ptr = transl env arg in @@ -1496,8 +1540,8 @@ let rec transl env e = (List.map (transl env) args) dbg | _ -> bind "met" (lookup_tag obj (transl env met)) (call_met obj args)) - | Ulet(id, exp, body) -> - transl_let env id exp body + | Ulet(str, kind, id, exp, body) -> + transl_let env str kind id exp body | Uletrec(bindings, body) -> transl_letrec env bindings (transl env body) @@ -1506,10 +1550,10 @@ let rec transl env e = begin match (simplif_primitive prim, args) with (Pgetglobal id, []) -> Cconst_symbol (Ident.name id) - | (Pmakeblock(tag, mut), []) -> + | (Pmakeblock _, []) -> assert false - | (Pmakeblock(tag, mut), args) -> - make_alloc tag (List.map (transl env) args) + | (Pmakeblock(tag, _mut, _kind), args) -> + make_alloc dbg tag (List.map (transl env) args) | (Pccall prim, args) -> transl_ccall env prim args dbg | (Pduparray (kind, _), [Uprim (Pmakearray (kind', _), args, _dbg)]) -> @@ -1524,29 +1568,29 @@ let rec transl env e = state of [Translcore], we will in fact only get here with [Pfloatarray]s. *) assert (kind = kind'); - transl_make_array env kind args + transl_make_array dbg 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, _), []) -> + | (Pmakearray _, []) -> transl_structured_constant (Uconst_block(0, [])) - | (Pmakearray (kind, _), args) -> transl_make_array env kind args - | (Pbigarrayref(unsafe, num_dims, elt_kind, layout), arg1 :: argl) -> + | (Pmakearray (kind, _), args) -> transl_make_array dbg env kind args + | (Pbigarrayref(unsafe, _num_dims, elt_kind, layout), arg1 :: argl) -> let elt = bigarray_get unsafe elt_kind layout (transl env arg1) (List.map (transl env) argl) dbg in begin match elt_kind with - Pbigarray_float32 | Pbigarray_float64 -> box_float elt + Pbigarray_float32 | Pbigarray_float64 -> box_float dbg elt | Pbigarray_complex32 | Pbigarray_complex64 -> elt - | Pbigarray_int32 -> box_int Pint32 elt - | Pbigarray_int64 -> box_int Pint64 elt - | Pbigarray_native_int -> box_int Pnativeint elt + | Pbigarray_int32 -> box_int dbg Pint32 elt + | Pbigarray_int64 -> box_int dbg Pint64 elt + | Pbigarray_native_int -> box_int dbg Pnativeint elt | Pbigarray_caml_int -> force_tag_int elt | _ -> tag_int elt end - | (Pbigarrayset(unsafe, num_dims, elt_kind, layout), arg1 :: argl) -> + | (Pbigarrayset(unsafe, _num_dims, elt_kind, layout), arg1 :: argl) -> let (argidx, argnewval) = split_last argl in return_unit(bigarray_set unsafe elt_kind layout (transl env arg1) @@ -1683,15 +1727,15 @@ let rec transl env e = | Uunreachable -> Cop(Cload Word_int, [Cconst_int 0]) -and transl_make_array env kind args = +and transl_make_array dbg 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)]) + Cop(Cextcall("caml_make_array", typ_val, true, Debuginfo.none, None), + [make_alloc dbg 0 (List.map (transl env) args)]) | Paddrarray | Pintarray -> - make_alloc 0 (List.map (transl env) args) + make_alloc dbg 0 (List.map (transl env) args) | Pfloatarray -> - make_float_alloc Obj.double_array_tag + make_float_alloc dbg Obj.double_array_tag (List.map (transl_unbox_float env) args) and transl_ccall env prim args dbg = @@ -1715,20 +1759,21 @@ and transl_ccall env prim args dbg = let typ_res, wrap_result = match prim.prim_native_repr_res with | Same_as_ocaml_repr -> (typ_val, fun x -> x) - | Unboxed_float -> (typ_float, box_float) - | Unboxed_integer Pint64 when size_int = 4 -> ([|Int; Int|], box_int Pint64) - | Unboxed_integer bi -> (typ_int, box_int bi) + | Unboxed_float -> (typ_float, box_float dbg) + | Unboxed_integer Pint64 when size_int = 4 -> + ([|Int; Int|], box_int dbg Pint64) + | Unboxed_integer bi -> (typ_int, box_int dbg bi) | Untagged_int -> (typ_int, tag_int) in let args = transl_args prim.prim_native_repr_args args in wrap_result (Cop(Cextcall(Primitive.native_name prim, - typ_res, prim.prim_alloc, dbg), args)) + typ_res, prim.prim_alloc, dbg, None), args)) and transl_prim_1 env p arg dbg = match p with (* Generic operations *) - Pidentity | Popaque -> + Pidentity | Pbytes_to_string | Pbytes_of_string | Popaque -> transl env arg | Pignore -> return_unit(remove_unit (transl env arg)) @@ -1737,7 +1782,7 @@ and transl_prim_1 env p arg dbg = get_field (transl env arg) n | Pfloatfield n -> let ptr = transl env arg in - box_float( + box_float dbg ( Cop(Cload Double_u, [if n = 0 then ptr else Cop(Cadda, [ptr; Cconst_int(n * size_float)])])) @@ -1745,8 +1790,14 @@ and transl_prim_1 env p arg dbg = Cop(Caddi, [transl env arg; Cconst_int (-1)]) (* always a pointer outside the heap *) (* Exceptions *) - | Praise k -> - Cop(Craise (k, dbg), [transl env arg]) + | Praise _ when not (!Clflags.debug) -> + Cop(Craise (Cmm.Raise_notrace, dbg), [transl env arg]) + | Praise Lambda.Raise_notrace -> + Cop(Craise (Cmm.Raise_notrace, dbg), [transl env arg]) + | Praise Lambda.Raise_reraise -> + Cop(Craise (Cmm.Raise_withtrace, dbg), [transl env arg]) + | Praise Lambda.Raise_regular -> + raise_regular dbg (transl env arg) (* Integer operations *) | Pnegint -> Cop(Csubi, [Cconst_int 2; transl env arg]) @@ -1762,6 +1813,8 @@ and transl_prim_1 env p arg dbg = | Ostype_unix -> const_of_bool (Sys.os_type = "Unix") | Ostype_win32 -> const_of_bool (Sys.os_type = "Win32") | Ostype_cygwin -> const_of_bool (Sys.os_type = "Cygwin") + | Backend_type -> + tag_int (Cconst_int 0) (* tag 0 is the same as Native here *) end | Poffsetint n -> if no_overflow_lsl n 1 then @@ -1776,15 +1829,15 @@ and transl_prim_1 env p arg dbg = [arg; add_const (Cop(Cload Word_int, [arg])) (n lsl 1)]))) (* Floating-point operations *) | Pfloatofint -> - box_float(Cop(Cfloatofint, [untag_int(transl env arg)])) + box_float dbg (Cop(Cfloatofint, [untag_int(transl env arg)])) | Pintoffloat -> tag_int(Cop(Cintoffloat, [transl_unbox_float env arg])) | Pnegfloat -> - box_float(Cop(Cnegf, [transl_unbox_float env arg])) + box_float dbg (Cop(Cnegf, [transl_unbox_float env arg])) | Pabsfloat -> - box_float(Cop(Cabsf, [transl_unbox_float env arg])) + box_float dbg (Cop(Cabsf, [transl_unbox_float env arg])) (* String operations *) - | Pstringlength -> + | Pstringlength | Pbyteslength -> tag_int(string_length (transl env arg)) (* Array operations *) | Parraylength kind -> @@ -1812,24 +1865,24 @@ and transl_prim_1 env p arg dbg = tag_int(Cop(Cand, [transl env arg; Cconst_int 1])) (* Boxed integers *) | Pbintofint bi -> - box_int bi (untag_int (transl env arg)) + box_int dbg bi (untag_int (transl env arg)) | Pintofbint bi -> force_tag_int (transl_unbox_int env bi arg) | Pcvtbint(bi1, bi2) -> - box_int bi2 (transl_unbox_int env bi1 arg) + box_int dbg bi2 (transl_unbox_int env bi1 arg) | Pnegbint bi -> - box_int bi (Cop(Csubi, [Cconst_int 0; transl_unbox_int env bi arg])) + box_int dbg bi (Cop(Csubi, [Cconst_int 0; transl_unbox_int env bi arg])) | Pbbswap bi -> let prim = match bi with | Pnativeint -> "nativeint" | Pint32 -> "int32" | Pint64 -> "int64" in - box_int bi (Cop(Cextcall(Printf.sprintf "caml_%s_direct_bswap" prim, - typ_int, false, Debuginfo.none), + box_int dbg bi (Cop(Cextcall(Printf.sprintf "caml_%s_direct_bswap" prim, + typ_int, false, Debuginfo.none, None), [transl_unbox_int env bi arg])) | Pbswap16 -> tag_int (Cop(Cextcall("caml_bswap16_direct", typ_int, false, - Debuginfo.none), + Debuginfo.none, None), [untag_int (transl env arg)])) | prim -> fatal_errorf "Cmmgen.transl_prim_1: %a" Printlambda.primitive prim @@ -1840,7 +1893,8 @@ and transl_prim_2 env p arg1 arg2 dbg = Psetfield(n, ptr, init) -> begin match init, ptr with | Assignment, Pointer -> - return_unit(Cop(Cextcall("caml_modify", typ_void, false,Debuginfo.none), + return_unit(Cop(Cextcall("caml_modify", typ_void, false,Debuginfo.none, + None), [field_address (transl env arg1) n; transl env arg2])) | Assignment, Immediate | Initialization, (Immediate | Pointer) -> @@ -1882,12 +1936,12 @@ and transl_prim_2 env p arg1 arg2 dbg = incr_int (mul_int (untag_int c1) (decr_int c2)) | c1, c2 -> incr_int (mul_int (decr_int c1) (untag_int c2)) end - | Pdivint -> + | Pdivint is_safe -> tag_int(div_int (untag_int(transl env arg1)) - (untag_int(transl env arg2)) dbg) - | Pmodint -> + (untag_int(transl env arg2)) is_safe dbg) + | Pmodint is_safe -> tag_int(mod_int (untag_int(transl env arg1)) - (untag_int(transl env arg2)) dbg) + (untag_int(transl env arg2)) is_safe dbg) | Pandint -> Cop(Cand, [transl env arg1; transl env arg2]) | Porint -> @@ -1911,26 +1965,26 @@ and transl_prim_2 env p arg1 arg2 dbg = transl_isout (transl env arg1) (transl env arg2) (* Float operations *) | Paddfloat -> - box_float(Cop(Caddf, + box_float dbg (Cop(Caddf, [transl_unbox_float env arg1; transl_unbox_float env arg2])) | Psubfloat -> - box_float(Cop(Csubf, + box_float dbg (Cop(Csubf, [transl_unbox_float env arg1; transl_unbox_float env arg2])) | Pmulfloat -> - box_float(Cop(Cmulf, + box_float dbg (Cop(Cmulf, [transl_unbox_float env arg1; transl_unbox_float env arg2])) | Pdivfloat -> - box_float(Cop(Cdivf, + box_float dbg (Cop(Cdivf, [transl_unbox_float env arg1; transl_unbox_float env arg2])) | Pfloatcomp cmp -> tag_int(Cop(Ccmpf(transl_comparison cmp), [transl_unbox_float env arg1; transl_unbox_float env arg2])) (* String operations *) - | Pstringrefu -> + | Pstringrefu | Pbytesrefu -> tag_int(Cop(Cload Byte_unsigned, [add_int (transl env arg1) (untag_int(transl env arg2))])) - | Pstringrefs -> + | Pstringrefs | Pbytesrefs -> tag_int (bind "str" (transl env arg1) (fun str -> bind "index" (untag_int (transl env arg2)) (fun idx -> @@ -1957,14 +2011,14 @@ and transl_prim_2 env p arg1 arg2 dbg = (unaligned_load_16 ba_data idx))))) | Pstring_load_32(unsafe) -> - box_int Pint32 + box_int dbg Pint32 (bind "str" (transl env arg1) (fun str -> bind "index" (untag_int (transl env arg2)) (fun idx -> check_bound unsafe dbg (sub_int (string_length str) (Cconst_int 3)) idx (unaligned_load_32 str idx)))) | Pbigstring_load_32(unsafe) -> - box_int Pint32 + box_int dbg Pint32 (bind "ba" (transl env arg1) (fun ba -> bind "index" (untag_int (transl env arg2)) (fun idx -> bind "ba_data" (Cop(Cload Word_int, [field_address ba 1])) @@ -1975,14 +2029,14 @@ and transl_prim_2 env p arg1 arg2 dbg = (unaligned_load_32 ba_data idx))))) | Pstring_load_64(unsafe) -> - box_int Pint64 + box_int dbg Pint64 (bind "str" (transl env arg1) (fun str -> bind "index" (untag_int (transl env arg2)) (fun idx -> check_bound unsafe dbg (sub_int (string_length str) (Cconst_int 7)) idx (unaligned_load_64 str idx)))) | Pbigstring_load_64(unsafe) -> - box_int Pint64 + box_int dbg Pint64 (bind "ba" (transl env arg1) (fun ba -> bind "index" (untag_int (transl env arg2)) (fun idx -> bind "ba_data" (Cop(Cload Word_int, [field_address ba 1])) @@ -2000,13 +2054,13 @@ and transl_prim_2 env p arg1 arg2 dbg = bind "index" (transl env arg2) (fun idx -> Cifthenelse(is_addr_array_ptr arr, addr_array_ref arr idx, - float_array_ref arr idx))) + float_array_ref dbg arr idx))) | Paddrarray -> addr_array_ref (transl env arg1) (transl env arg2) | Pintarray -> int_array_ref (transl env arg1) (transl env arg2) | Pfloatarray -> - float_array_ref (transl env arg1) (transl env arg2) + float_array_ref dbg (transl env arg1) (transl env arg2) end | Parrayrefs kind -> begin match kind with @@ -2018,13 +2072,13 @@ and transl_prim_2 env p arg1 arg2 dbg = Csequence(make_checkbound dbg [addr_array_length hdr; idx], Cifthenelse(is_addr_array_hdr hdr, addr_array_ref arr idx, - float_array_ref arr idx)) + float_array_ref dbg arr idx)) else Cifthenelse(is_addr_array_hdr hdr, Csequence(make_checkbound dbg [addr_array_length hdr; idx], addr_array_ref arr idx), Csequence(make_checkbound dbg [float_array_length hdr; idx], - float_array_ref arr idx))))) + float_array_ref dbg arr idx))))) | Paddrarray -> bind "index" (transl env arg2) (fun idx -> bind "arr" (transl env arg1) (fun arr -> @@ -2036,7 +2090,7 @@ and transl_prim_2 env p arg1 arg2 dbg = Csequence(make_checkbound dbg [addr_array_length(header arr); idx], int_array_ref arr idx))) | Pfloatarray -> - box_float( + box_float dbg ( bind "index" (transl env arg2) (fun idx -> bind "arr" (transl env arg1) (fun arr -> Csequence(make_checkbound dbg @@ -2056,49 +2110,49 @@ and transl_prim_2 env p arg1 arg2 dbg = (* Boxed integers *) | Paddbint bi -> - box_int bi (Cop(Caddi, + box_int dbg bi (Cop(Caddi, [transl_unbox_int env bi arg1; transl_unbox_int env bi arg2])) | Psubbint bi -> - box_int bi (Cop(Csubi, + box_int dbg bi (Cop(Csubi, [transl_unbox_int env bi arg1; transl_unbox_int env bi arg2])) | Pmulbint bi -> - box_int bi (Cop(Cmuli, + box_int dbg bi (Cop(Cmuli, [transl_unbox_int env bi arg1; transl_unbox_int env bi arg2])) - | Pdivbint bi -> - box_int bi (safe_div_bi + | Pdivbint { size = bi; is_safe } -> + box_int dbg bi (safe_div_bi is_safe (transl_unbox_int env bi arg1) (transl_unbox_int env bi arg2) bi dbg) - | Pmodbint bi -> - box_int bi (safe_mod_bi + | Pmodbint { size = bi; is_safe } -> + box_int dbg bi (safe_mod_bi is_safe (transl_unbox_int env bi arg1) (transl_unbox_int env bi arg2) bi dbg) | Pandbint bi -> - box_int bi (Cop(Cand, + box_int dbg bi (Cop(Cand, [transl_unbox_int env bi arg1; transl_unbox_int env bi arg2])) | Porbint bi -> - box_int bi (Cop(Cor, + box_int dbg bi (Cop(Cor, [transl_unbox_int env bi arg1; transl_unbox_int env bi arg2])) | Pxorbint bi -> - box_int bi (Cop(Cxor, + box_int dbg bi (Cop(Cxor, [transl_unbox_int env bi arg1; transl_unbox_int env bi arg2])) | Plslbint bi -> - box_int bi (Cop(Clsl, + box_int dbg bi (Cop(Clsl, [transl_unbox_int env bi arg1; untag_int(transl env arg2)])) | Plsrbint bi -> - box_int bi (Cop(Clsr, + box_int dbg bi (Cop(Clsr, [make_unsigned_int bi (transl_unbox_int env bi arg1); untag_int(transl env arg2)])) | Pasrbint bi -> - box_int bi (Cop(Casr, + box_int dbg bi (Cop(Casr, [transl_unbox_int env bi arg1; untag_int(transl env arg2)])) | Pbintcomp(bi, cmp) -> @@ -2111,11 +2165,11 @@ and transl_prim_2 env p arg1 arg2 dbg = and transl_prim_3 env p arg1 arg2 arg3 dbg = match p with (* String operations *) - Pstringsetu -> + | Pbytessetu -> return_unit(Cop(Cstore (Byte_unsigned, Assignment), [add_int (transl env arg1) (untag_int(transl env arg2)); untag_int(transl env arg3)])) - | Pstringsets -> + | Pbytessets -> return_unit (bind "str" (transl env arg1) (fun str -> bind "index" (untag_int (transl env arg2)) (fun idx -> @@ -2269,18 +2323,44 @@ and transl_unbox_int env bi = function and transl_unbox_number env bn arg = match bn with - | Boxed_float -> transl_unbox_float env arg - | Boxed_integer bi -> transl_unbox_int env bi arg - -and transl_let env id exp body = - match is_unboxed_number env exp with - | No_unboxing -> + | Boxed_float _ -> transl_unbox_float env arg + | Boxed_integer (bi, _) -> transl_unbox_int env bi arg + +and transl_let env str kind id exp body = + let unboxing = + (* If [id] is a mutable variable (introduced to eliminate a local + reference) and it contains a type of unboxable numbers, then + force unboxing. Indeed, if not boxed, each assignment to the variable + might require some boxing, but such local references are often + used in loops and we really want to avoid repeated boxing. *) + match str, kind with + | Mutable, Pfloatval -> + Boxed (Boxed_float Debuginfo.none, false) + | Mutable, Pboxedintval bi -> + Boxed (Boxed_integer (bi, Debuginfo.none), false) + | _, (Pfloatval | Pboxedintval _) -> + (* It would be safe to always unbox in this case, but + we do it only if this indeed allows us to get rid of + some allocations in the bound expression. *) + is_unboxed_number ~strict:false env exp + | _, Pgenval -> + (* Here we don't know statically that the bound expression + evaluates to an unboxable number type. We need to be stricter + and ensure that all possible branches in the expression + return a boxed value (of the same kind). Indeed, with GADTs, + different branches could return different types. *) + is_unboxed_number ~strict:true env exp + | _, Pintval -> + No_unboxing + in + match unboxing with + | No_unboxing | Boxed (_, true) -> Clet(id, transl env exp, transl env body) | No_result -> (* the let-bound expression never returns a value, we can ignore the body *) transl env exp - | Boxed boxed_number -> + | Boxed (boxed_number, _false) -> let unboxed_id = Ident.create (Ident.name id) in Clet(unboxed_id, transl_unbox_number env boxed_number exp, transl (add_unboxed_id id unboxed_id boxed_number env) body) @@ -2404,18 +2484,18 @@ and transl_letrec env bindings cont = let bsz = List.map (fun (id, exp) -> (id, exp, expr_size Ident.empty exp)) bindings in let op_alloc prim sz = - Cop(Cextcall(prim, typ_val, true, Debuginfo.none), [int_const sz]) in + Cop(Cextcall(prim, typ_val, true, Debuginfo.none, None), [int_const sz]) in let rec init_blocks = function | [] -> fill_nonrec bsz - | (id, exp, RHS_block sz) :: rem -> + | (id, _exp, RHS_block sz) :: rem -> Clet(id, op_alloc "caml_alloc_dummy" sz, init_blocks rem) - | (id, exp, RHS_floatblock sz) :: rem -> + | (id, _exp, RHS_floatblock sz) :: rem -> Clet(id, op_alloc "caml_alloc_dummy_float" sz, init_blocks rem) - | (id, exp, RHS_nonrec) :: rem -> + | (id, _exp, RHS_nonrec) :: rem -> Clet (id, Cconst_int 0, init_blocks rem) and fill_nonrec = function | [] -> fill_blocks bsz - | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem -> + | (_id, _exp, (RHS_block _ | RHS_floatblock _)) :: rem -> fill_nonrec rem | (id, exp, RHS_nonrec) :: rem -> Clet(id, transl env exp, fill_nonrec rem) @@ -2423,10 +2503,11 @@ and transl_letrec env bindings cont = | [] -> cont | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem -> let op = - Cop(Cextcall("caml_update_dummy", typ_void, false, Debuginfo.none), + Cop(Cextcall("caml_update_dummy", typ_void, false, Debuginfo.none, + None), [Cvar id; transl env exp]) in Csequence(op, fill_blocks rem) - | (id, exp, RHS_nonrec) :: rem -> + | (_id, _exp, RHS_nonrec) :: rem -> fill_blocks rem in init_blocks bsz @@ -2461,7 +2542,7 @@ let rec transl_all_functions already_translated cont = else begin transl_all_functions (StringSet.add f.label already_translated) - (transl_function f :: cont) + ((f.dbg, transl_function f) :: cont) end with Queue.Empty -> cont, already_translated @@ -2613,16 +2694,27 @@ let emit_all_constants cont = emit_constants cont constants let transl_all_functions_and_emit_all_constants cont = - let rec aux already_translated cont = + let rec aux already_translated cont translated_functions = if Compilenv.structured_constants () = [] && Queue.is_empty functions - then cont + then cont, translated_functions else - let cont, set = transl_all_functions already_translated cont in + let translated_functions, already_translated = + transl_all_functions already_translated translated_functions + in let cont = emit_all_constants cont in - aux already_translated cont + aux already_translated cont translated_functions + in + let cont, translated_functions = + aux StringSet.empty cont [] in - aux StringSet.empty cont + let translated_functions = + (* Sort functions according to source position *) + List.map snd + (List.sort (fun (dbg1, _) (dbg2, _) -> + Debuginfo.compare dbg1 dbg2) translated_functions) + in + translated_functions @ cont (* Build the NULL terminated array of gc roots *) @@ -2902,15 +2994,15 @@ let rec intermediate_curry_functions arity num = fun_args = [arg, typ_val; clos, typ_val]; fun_body = if arity - num > 2 && arity <= max_arity_optimized then - Cop(Calloc, - [alloc_closure_header 5; + Cop(Calloc Debuginfo.none, + [alloc_closure_header 5 Debuginfo.none; Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1)); int_const (arity - num - 1); Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1) ^ "_app"); Cvar arg; Cvar clos]) else - Cop(Calloc, - [alloc_closure_header 4; + Cop(Calloc Debuginfo.none, + [alloc_closure_header 4 Debuginfo.none; Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1)); int_const 1; Cvar arg; Cvar clos]); fun_fast = true; @@ -3036,6 +3128,18 @@ let frame_table namelist = List.map mksym namelist @ [cint_zero]) +(* Generate the master table of Spacetime shapes *) + +let spacetime_shapes namelist = + let mksym name = + Csymbol_address ( + Compilenv.make_symbol ~unitname:name (Some "spacetime_shapes")) + in + Cdata(Cglobal_symbol "caml_spacetime_shapes" :: + Cdefine_symbol "caml_spacetime_shapes" :: + List.map mksym namelist + @ [cint_zero]) + (* Generate the table of module data and code segments *) let segment_table namelist symbol begname endname = diff --git a/asmcomp/cmmgen.mli b/asmcomp/cmmgen.mli index 1843fac5..8104afab 100644 --- a/asmcomp/cmmgen.mli +++ b/asmcomp/cmmgen.mli @@ -31,7 +31,9 @@ val reference_symbols: string list -> Cmm.phrase val globals_map: (string * Digest.t * Digest.t * string list) list -> Cmm.phrase val frame_table: string list -> Cmm.phrase +val spacetime_shapes: string list -> Cmm.phrase val data_segment_table: string list -> Cmm.phrase val code_segment_table: string list -> Cmm.phrase val predef_exception: int -> string -> Cmm.phrase val plugin_header: (Cmx_format.unit_infos * Digest.t) list -> Cmm.phrase +val black_block_header: (*tag:*)int -> (*size:*)int -> nativeint diff --git a/asmcomp/comballoc.ml b/asmcomp/comballoc.ml index 094cdb89..e33acd06 100644 --- a/asmcomp/comballoc.ml +++ b/asmcomp/comballoc.ml @@ -26,18 +26,20 @@ type allocation_state = let allocated_size = function No_alloc -> 0 - | Pending_alloc(reg, ofs) -> ofs + | Pending_alloc(_, ofs) -> ofs let rec combine i allocstate = match i.desc with Iend | Ireturn | Iexit _ | Iraise _ -> (i, allocated_size allocstate) - | Iop(Ialloc sz) -> + | Iop(Ialloc { words = sz; _ }) -> begin match allocstate with No_alloc -> let (newnext, newsz) = combine i.next (Pending_alloc(i.res.(0), sz)) in - (instr_cons (Iop(Ialloc newsz)) i.arg i.res newnext, 0) + (instr_cons_debug (Iop(Ialloc {words = newsz; spacetime_index = 0; + label_after_call_gc = None; })) + i.arg i.res i.dbg newnext, 0) | Pending_alloc(reg, ofs) -> if ofs + sz < Config.max_young_wosize * Arch.size_addr then begin let (newnext, newsz) = @@ -47,15 +49,17 @@ let rec combine i allocstate = end else begin let (newnext, newsz) = combine i.next (Pending_alloc(i.res.(0), sz)) in - (instr_cons (Iop(Ialloc newsz)) i.arg i.res newnext, ofs) + (instr_cons_debug (Iop(Ialloc { words = newsz; spacetime_index = 0; + label_after_call_gc = None; })) + i.arg i.res i.dbg newnext, ofs) end end - | Iop(Icall_ind | Icall_imm _ | Iextcall _ | - Itailcall_ind | Itailcall_imm _) -> + | Iop(Icall_ind _ | Icall_imm _ | Iextcall _ | + Itailcall_ind _ | Itailcall_imm _) -> let newnext = combine_restart i.next in (instr_cons_debug i.desc i.arg i.res i.dbg newnext, allocated_size allocstate) - | Iop op -> + | Iop _ -> let (newnext, sz) = combine i.next allocstate in (instr_cons_debug i.desc i.arg i.res i.dbg newnext, sz) | Iifthenelse(test, ifso, ifnot) -> @@ -88,4 +92,5 @@ and combine_restart i = let (newi, _) = combine i No_alloc in newi let fundecl f = - {f with fun_body = combine_restart f.fun_body} + if Config.spacetime then f + else {f with fun_body = combine_restart f.fun_body} diff --git a/asmcomp/compilenv.ml b/asmcomp/compilenv.ml index 8133c396..9847cb93 100644 --- a/asmcomp/compilenv.ml +++ b/asmcomp/compilenv.ml @@ -432,6 +432,10 @@ let function_label fv = in (concat_symbol unitname (Closure_id.unique_name fv)) +let require_global global_ident = + if not (Ident.is_predef_exn global_ident) then + ignore (get_global_info global_ident : Cmx_format.unit_infos option) + (* Error report *) open Format diff --git a/asmcomp/compilenv.mli b/asmcomp/compilenv.mli index 2974eae0..32813bdb 100644 --- a/asmcomp/compilenv.mli +++ b/asmcomp/compilenv.mli @@ -142,6 +142,10 @@ val cache_unit_info: unit_infos -> unit honored by [symbol_for_global] and [global_approx] without looking at the corresponding .cmx file. *) +val require_global: Ident.t -> unit + (* Enforce a link dependency of the current compilation + unit to the required module *) + val read_library_info: string -> library_infos type error = diff --git a/asmcomp/deadcode.ml b/asmcomp/deadcode.ml index 4570d8ef..42981ded 100644 --- a/asmcomp/deadcode.ml +++ b/asmcomp/deadcode.ml @@ -22,32 +22,38 @@ open Mach and a set of registers live "before" instruction [i]. *) let rec deadcode i = + let arg = + if Config.spacetime + && Mach.spacetime_node_hole_pointer_is_live_before i + then Array.append i.arg [| Proc.loc_spacetime_node_hole |] + else i.arg + in match i.desc with - | Iend | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) | Iraise _ -> - (i, Reg.add_set_array i.live i.arg) + | Iend | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) | Iraise _ -> + (i, Reg.add_set_array i.live arg) | Iop op -> let (s, before) = deadcode i.next in if Proc.op_is_pure op (* no side effects *) && Reg.disjoint_set_array before i.res (* results are not used after *) - && not (Proc.regs_are_volatile i.arg) (* no stack-like hard reg *) + && not (Proc.regs_are_volatile arg) (* no stack-like hard reg *) && not (Proc.regs_are_volatile i.res) (* is involved *) then begin assert (Array.length i.res > 0); (* sanity check *) (s, before) end else begin - ({i with next = s}, Reg.add_set_array i.live i.arg) + ({i with next = s}, Reg.add_set_array i.live arg) end | Iifthenelse(test, ifso, ifnot) -> let (ifso', _) = deadcode ifso in let (ifnot', _) = deadcode ifnot in let (s, _) = deadcode i.next in ({i with desc = Iifthenelse(test, ifso', ifnot'); next = s}, - Reg.add_set_array i.live i.arg) + Reg.add_set_array i.live arg) | Iswitch(index, cases) -> let cases' = Array.map (fun c -> fst (deadcode c)) cases in let (s, _) = deadcode i.next in ({i with desc = Iswitch(index, cases'); next = s}, - Reg.add_set_array i.live i.arg) + Reg.add_set_array i.live arg) | Iloop(body) -> let (body', _) = deadcode body in let (s, _) = deadcode i.next in @@ -57,7 +63,7 @@ let rec deadcode i = let (handler', _) = deadcode handler in let (s, _) = deadcode i.next in ({i with desc = Icatch(nfail, body', handler'); next = s}, i.live) - | Iexit nfail -> + | Iexit _ -> (i, i.live) | Itrywith(body, handler) -> let (body', _) = deadcode body in diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml index 4ba28d2a..1149814a 100644 --- a/asmcomp/emitaux.ml +++ b/asmcomp/emitaux.ml @@ -15,8 +15,6 @@ (* Common functions for emitting assembly code *) -open Debuginfo - let output_channel = ref stdout let emit_string s = output_string !output_channel s @@ -111,12 +109,14 @@ type frame_descr = { fd_lbl: int; (* Return address *) fd_frame_size: int; (* Size of stack frame *) fd_live_offset: int list; (* Offsets/regs of live addresses *) + fd_raise: bool; (* Is frame for a raise? *) fd_debuginfo: Debuginfo.t } (* Location, if any *) let frame_descriptors = ref([] : frame_descr list) type emit_frame_actions = - { efa_label: int -> unit; + { efa_code_label: int -> unit; + efa_data_label: int -> unit; efa_16: int -> unit; efa_32: int32 -> unit; efa_word: int -> unit; @@ -131,39 +131,72 @@ let emit_frames a = try Hashtbl.find filenames name with Not_found -> - let lbl = Linearize.new_label () in + let lbl = Cmm.new_label () in Hashtbl.add filenames name lbl; - lbl in + lbl + in + let debuginfos = Hashtbl.create 7 in + let rec label_debuginfos rs rdbg = + let key = (rs, rdbg) in + try fst (Hashtbl.find debuginfos key) + with Not_found -> + let lbl = Cmm.new_label () in + let next = + match rdbg with + | [] -> assert false + | _ :: [] -> None + | _ :: ((_ :: _) as rdbg') -> Some (label_debuginfos false rdbg') + in + Hashtbl.add debuginfos key (lbl, next); + lbl + in + let emit_debuginfo_label rs rdbg = + a.efa_data_label (label_debuginfos rs rdbg) + in let emit_frame fd = - a.efa_label fd.fd_lbl; + a.efa_code_label fd.fd_lbl; a.efa_16 (if Debuginfo.is_none fd.fd_debuginfo then fd.fd_frame_size else fd.fd_frame_size + 1); a.efa_16 (List.length fd.fd_live_offset); List.iter a.efa_16 fd.fd_live_offset; a.efa_align Arch.size_addr; - if not (Debuginfo.is_none fd.fd_debuginfo) then begin - let d = fd.fd_debuginfo in - let line = min 0xFFFFF d.dinfo_line - and char_start = min 0xFF d.dinfo_char_start - and char_end = min 0x3FF d.dinfo_char_end - and kind = match d.dinfo_kind with Dinfo_call -> 0 | Dinfo_raise -> 1 in - let info = - Int64.add (Int64.shift_left (Int64.of_int line) 44) ( - Int64.add (Int64.shift_left (Int64.of_int char_start) 36) ( - Int64.add (Int64.shift_left (Int64.of_int char_end) 26) - (Int64.of_int kind))) in - a.efa_label_rel - (label_filename d.dinfo_file) - (Int64.to_int32 info); - a.efa_32 (Int64.to_int32 (Int64.shift_right info 32)) - end in + match List.rev fd.fd_debuginfo with + | [] -> () + | _ :: _ as rdbg -> emit_debuginfo_label fd.fd_raise rdbg + in let emit_filename name lbl = a.efa_def_label lbl; a.efa_string name; - a.efa_align Arch.size_addr in + a.efa_align Arch.size_addr + in + let pack_info fd_raise d = + let line = min 0xFFFFF d.Debuginfo.dinfo_line + and char_start = min 0xFF d.Debuginfo.dinfo_char_start + and char_end = min 0x3FF d.Debuginfo.dinfo_char_end + and kind = if fd_raise then 1 else 0 in + Int64.(add (shift_left (of_int line) 44) + (add (shift_left (of_int char_start) 36) + (add (shift_left (of_int char_end) 26) + (of_int kind)))) + in + let emit_debuginfo (rs, rdbg) (lbl,next) = + let d = List.hd rdbg in + a.efa_align Arch.size_addr; + a.efa_def_label lbl; + let info = pack_info rs d in + a.efa_label_rel + (label_filename d.Debuginfo.dinfo_file) + (Int64.to_int32 info); + a.efa_32 (Int64.to_int32 (Int64.shift_right info 32)); + begin match next with + | Some next -> a.efa_data_label next + | None -> a.efa_word 0 + end + in a.efa_word (List.length !frame_descriptors); List.iter emit_frame !frame_descriptors; + Hashtbl.iter emit_debuginfo debuginfos; Hashtbl.iter emit_filename filenames; frame_descriptors := [] @@ -225,23 +258,23 @@ let reset_debug_info () = display .loc for every instruction. *) let emit_debug_info_gen dbg file_emitter loc_emitter = if is_cfi_enabled () && - (!Clflags.debug || Config.with_frame_pointers) - && dbg.Debuginfo.dinfo_line > 0 (* PR#6243 *) - then begin - let { Debuginfo. - dinfo_line = line; - dinfo_char_start = col; - dinfo_file = file_name; - } = dbg in - let file_num = - try List.assoc file_name !file_pos_nums - with Not_found -> - let file_num = !file_pos_num_cnt in - incr file_pos_num_cnt; - file_emitter ~file_num ~file_name; - file_pos_nums := (file_name,file_num) :: !file_pos_nums; - file_num in - loc_emitter ~file_num ~line ~col; + (!Clflags.debug || Config.with_frame_pointers) then begin + match List.rev dbg with + | [] -> () + | { Debuginfo.dinfo_line = line; + dinfo_char_start = col; + dinfo_file = file_name; } :: _ -> + if line > 0 then begin (* PR#6243 *) + let file_num = + try List.assoc file_name !file_pos_nums + with Not_found -> + let file_num = !file_pos_num_cnt in + incr file_pos_num_cnt; + file_emitter ~file_num ~file_name; + file_pos_nums := (file_name,file_num) :: !file_pos_nums; + file_num in + loc_emitter ~file_num ~line ~col; + end end let emit_debug_info dbg = diff --git a/asmcomp/emitaux.mli b/asmcomp/emitaux.mli index 093b589f..1e4addd3 100644 --- a/asmcomp/emitaux.mli +++ b/asmcomp/emitaux.mli @@ -42,12 +42,14 @@ type frame_descr = { fd_lbl: int; (* Return address *) fd_frame_size: int; (* Size of stack frame *) fd_live_offset: int list; (* Offsets/regs of live addresses *) + fd_raise: bool; (* Is frame for a raise? *) fd_debuginfo: Debuginfo.t } (* Location, if any *) val frame_descriptors : frame_descr list ref type emit_frame_actions = - { efa_label: int -> unit; + { efa_code_label: int -> unit; + efa_data_label: int -> unit; efa_16: int -> unit; efa_32: int32 -> unit; efa_word: int -> unit; diff --git a/asmcomp/flambda_to_clambda.ml b/asmcomp/flambda_to_clambda.ml index a5a0bd76..9ae0ecf9 100644 --- a/asmcomp/flambda_to_clambda.ml +++ b/asmcomp/flambda_to_clambda.ml @@ -230,33 +230,18 @@ let to_clambda_const env (const : Flambda.constant_defining_value_block_field) | Const (Char c) -> Uconst_int (Char.code c) | Const (Const_pointer i) -> Uconst_ptr i -(* CR-someday mshinwell: We should improve debug info / location handling - so that we don't need to do this. *) -(* Erase debug info created with high probability by [Debuginfo.from_filename] - (currently only used for emission of warning 59, which happens prior to - this pass). Failure to do this will cause erroneous empty frames in - backtraces. *) -let erase_empty_debuginfo (dbg : Debuginfo.t) = - if dbg.dinfo_kind = Debuginfo.Dinfo_call - && dbg.dinfo_line = 0 - && dbg.dinfo_char_start = 0 - && dbg.dinfo_char_end = 0 - then - Debuginfo.none - else - dbg - let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda = match flam with | Var var -> subst_var env var | Let { var; defining_expr; body; _ } -> + (* TODO: synthesize proper value_kind *) let id, env_body = Env.add_fresh_ident env var in - Ulet (id, to_clambda_named t env var defining_expr, + Ulet (Immutable, Pgenval, id, to_clambda_named t env var defining_expr, to_clambda t env_body body) - | Let_mutable (mut_var, var, body) -> + | Let_mutable { var = mut_var; initial_value = var; body; contents_kind } -> let id, env_body = Env.add_fresh_mutable_ident env mut_var in let def = subst_var env var in - Ulet (id, def, to_clambda t env_body body) + Ulet (Mutable, contents_kind, id, def, to_clambda t env_body body) | Let_rec (defs, body) -> let env, defs = List.fold_right (fun (var, def) (env, defs) -> @@ -408,19 +393,15 @@ and to_clambda_named t env var (named : Flambda.named) : Clambda.ulambda = [check_field (check_closure ulam (Expr (Var closure))) pos (Some named)], Debuginfo.none) | Prim (Pfield index, [block], dbg) -> - let dbg = erase_empty_debuginfo dbg in Uprim (Pfield index, [check_field (subst_var env block) index None], dbg) | Prim (Psetfield (index, maybe_ptr, init), [block; new_value], dbg) -> - let dbg = erase_empty_debuginfo dbg in Uprim (Psetfield (index, maybe_ptr, init), [ check_field (subst_var env block) index None; subst_var env new_value; ], dbg) | Prim (Popaque, args, dbg) -> - let dbg = erase_empty_debuginfo dbg in Uprim (Pidentity, subst_vars env args, dbg) | Prim (p, args, dbg) -> - let dbg = erase_empty_debuginfo dbg in Uprim (p, subst_vars env args, dbg) | Expr expr -> to_clambda t env expr diff --git a/asmcomp/i386/CSE.ml b/asmcomp/i386/CSE.ml index 85c7223f..6ef8fec6 100644 --- a/asmcomp/i386/CSE.ml +++ b/asmcomp/i386/CSE.ml @@ -20,7 +20,7 @@ open Arch open Mach open CSEgen -class cse = object (self) +class cse = object inherit cse_generic as super @@ -40,7 +40,7 @@ method! class_of_operation op = method! is_cheap_operation op = match op with - | Iconst_int _ | Iconst_blockheader _ -> true + | Iconst_int _ -> true | Iconst_symbol _ -> true | _ -> false diff --git a/asmcomp/i386/arch.ml b/asmcomp/i386/arch.ml index b17188af..23f54232 100644 --- a/asmcomp/i386/arch.ml +++ b/asmcomp/i386/arch.ml @@ -52,6 +52,8 @@ type specific_operation = and float_operation = Ifloatadd | Ifloatsub | Ifloatsubrev | Ifloatmul | Ifloatdiv | Ifloatdivrev +let spacetime_node_hole_pointer_is_live_before _specific_op = false + (* Sizes, endianness *) let big_endian = false @@ -79,11 +81,11 @@ let offset_addressing addr delta = | Iindexed2scaled(scale, n) -> Iindexed2scaled(scale, n + delta) let num_args_addressing = function - Ibased(s, n) -> 0 - | Iindexed n -> 1 - | Iindexed2 n -> 2 - | Iscaled(scale, n) -> 1 - | Iindexed2scaled(scale, n) -> 2 + Ibased _ -> 0 + | Iindexed _ -> 1 + | Iindexed2 _ -> 2 + | Iscaled _ -> 1 + | Iindexed2scaled _ -> 2 (* Printing operations and addressing modes *) diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp index 2a261fb6..d3325e1d 100644 --- a/asmcomp/i386/emit.mlp +++ b/asmcomp/i386/emit.mlp @@ -116,9 +116,6 @@ let label_prefix = let emit_label lbl = Printf.sprintf "%s%d" label_prefix lbl -let emit_data_label lbl = - Printf.sprintf "%sd%d" label_prefix lbl - let label s = sym (emit_label s) let def_label s = D.label (emit_label s) @@ -193,8 +190,12 @@ let addressing addr typ i n = (* Record live pointers at call points *) -let record_frame_label live dbg = - let lbl = new_label() in +let record_frame_label ?label live raise_ dbg = + let lbl = + match label with + | None -> new_label() + | Some label -> label + in let live_offset = ref [] in Reg.Set.iter (function @@ -210,11 +211,12 @@ let record_frame_label live dbg = { fd_lbl = lbl; fd_frame_size = frame_size(); fd_live_offset = !live_offset; + fd_raise = raise_; fd_debuginfo = dbg } :: !frame_descriptors; lbl -let record_frame live dbg = - let lbl = record_frame_label live dbg in +let record_frame ?label live raise_ dbg = + let lbl = record_frame_label ?label live raise_ dbg in def_label lbl (* Record calls to the GC -- we've moved them out of the way *) @@ -243,10 +245,10 @@ type bound_error_call = let bound_error_sites = ref ([] : bound_error_call list) let bound_error_call = ref 0 -let bound_error_label dbg = +let bound_error_label ?label dbg = if !Clflags.debug then begin let lbl_bound_error = new_label() in - let lbl_frame = record_frame_label Reg.Set.empty dbg in + let lbl_frame = record_frame_label ?label Reg.Set.empty false dbg in bound_error_sites := { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites; lbl_bound_error @@ -496,7 +498,7 @@ let emit_instr fallthrough i = else I.mov (reg src) (reg dst) end - | Lop(Iconst_int n | Iconst_blockheader n) -> + | Lop(Iconst_int n) -> if n = 0n then begin match i.res.(0).loc with | Reg _ -> I.xor (reg i.res.(0)) (reg i.res.(0)) @@ -520,46 +522,46 @@ let emit_instr fallthrough i = | Lop(Iconst_symbol s) -> add_used_symbol s; I.mov (immsym s) (reg i.res.(0)) - | Lop(Icall_ind) -> + | Lop(Icall_ind { label_after; }) -> I.call (reg i.arg.(0)); - record_frame i.live i.dbg - | Lop(Icall_imm s) -> - add_used_symbol s; - emit_call s; - record_frame i.live i.dbg - | Lop(Itailcall_ind) -> + record_frame i.live false i.dbg ~label:label_after + | Lop(Icall_imm { func; label_after; }) -> + add_used_symbol func; + emit_call func; + record_frame i.live false i.dbg ~label:label_after + | Lop(Itailcall_ind { label_after = _; }) -> output_epilogue begin fun () -> I.jmp (reg i.arg.(0)) end - | Lop(Itailcall_imm s) -> - if s = !function_name then + | Lop(Itailcall_imm { func; label_after = _; }) -> + if func = !function_name then I.jmp (label !tailrec_entry_point) else begin output_epilogue begin fun () -> - add_used_symbol s; - I.jmp (immsym s) + add_used_symbol func; + I.jmp (immsym func) end end - | Lop(Iextcall(s, alloc)) -> - add_used_symbol s; + | Lop(Iextcall { func; alloc; label_after; }) -> + add_used_symbol func; if alloc then begin if system <> S_macosx then - I.mov (immsym s) eax + I.mov (immsym func) eax else begin external_symbols_indirect := - StringSet.add s !external_symbols_indirect; + StringSet.add func !external_symbols_indirect; I.mov (mem_sym DWORD (Printf.sprintf "L%s$non_lazy_ptr" - (emit_symbol s))) eax + (emit_symbol func))) eax end; emit_call "caml_c_call"; - record_frame i.live i.dbg + record_frame i.live false i.dbg ~label:label_after end else begin if system <> S_macosx then - emit_call s + emit_call func else begin external_symbols_direct := - StringSet.add s !external_symbols_direct; - I.call (sym (Printf.sprintf "L%s$stub" (emit_symbol s))) + StringSet.add func !external_symbols_direct; + I.call (sym (Printf.sprintf "L%s$stub" (emit_symbol func))) end end | Lop(Istackoffset n) -> @@ -609,7 +611,7 @@ let emit_instr fallthrough i = I.fstp (addressing addr REAL8 i 1) end end - | Lop(Ialloc n) -> + | Lop(Ialloc { words = n; label_after_call_gc; }) -> if !fastcode_flag then begin let lbl_redo = new_label() in def_label lbl_redo; @@ -618,7 +620,7 @@ let emit_instr fallthrough i = I.mov eax (sym32 "caml_young_ptr"); I.cmp (sym32 "caml_young_limit") eax; let lbl_call_gc = new_label() in - let lbl_frame = record_frame_label i.live Debuginfo.none in + let lbl_frame = record_frame_label i.live false Debuginfo.none in I.jb (label lbl_call_gc); I.lea (mem32 NONE 4 RAX) (reg i.res.(0)); call_gc_sites := @@ -634,7 +636,11 @@ let emit_instr fallthrough i = I.mov (int n) eax; emit_call "caml_allocN" end; - record_frame i.live Debuginfo.none; + let label = + record_frame_label ?label:label_after_call_gc i.live false + Debuginfo.none + in + def_label label; I.lea (mem32 NONE 4 RAX) (reg i.res.(0)) end | Lop(Iintop(Icomp cmp)) -> @@ -645,12 +651,12 @@ let emit_instr fallthrough i = I.cmp (int n) (reg i.arg.(0)); I.set (cond cmp) al; I.movzx al (reg i.res.(0)) - | Lop(Iintop Icheckbound) -> - let lbl = bound_error_label i.dbg in + | Lop(Iintop (Icheckbound { label_after_error; } )) -> + let lbl = bound_error_label ?label:label_after_error i.dbg in I.cmp (reg i.arg.(1)) (reg i.arg.(0)); I.jbe (label lbl) - | Lop(Iintop_imm(Icheckbound, n)) -> - let lbl = bound_error_label i.dbg in + | Lop(Iintop_imm(Icheckbound { label_after_error; }, n)) -> + let lbl = bound_error_label ?label:label_after_error i.dbg in I.cmp (int n) (reg i.arg.(0)); I.jbe (label lbl) | Lop(Iintop(Idiv | Imod)) -> @@ -869,15 +875,11 @@ let emit_instr fallthrough i = cfi_adjust_cfa_offset (-trap_frame_size); stack_offset := !stack_offset - trap_frame_size | Lraise k -> - begin match !Clflags.debug, k with - | true, Lambda.Raise_regular -> + begin match k with + | Cmm.Raise_withtrace -> emit_call "caml_raise_exn"; - record_frame Reg.Set.empty i.dbg - | true, Lambda.Raise_reraise -> - emit_call "caml_reraise_exn"; - record_frame Reg.Set.empty i.dbg - | false, _ - | true, Lambda.Raise_notrace -> + record_frame Reg.Set.empty true i.dbg + | Cmm.Raise_notrace -> I.mov (sym32 "caml_exception_pointer") esp; I.pop (sym32 "caml_exception_pointer"); if trap_frame_size > 8 then @@ -989,7 +991,6 @@ let fundecl fundecl = let emit_item = function | Cglobal_symbol s -> D.global (emit_symbol s) | Cdefine_symbol s -> add_def_symbol s; _label (emit_symbol s) - | Cdefine_label lbl -> _label (emit_data_label lbl) | Cint8 n -> D.byte (const n) | Cint16 n -> D.word (const n) | Cint32 n -> D.long (const_nat n) @@ -997,7 +998,6 @@ let emit_item = function | Csingle f -> D.long (Const (Int64.of_int32 (Int32.bits_of_float f))) | Cdouble f -> emit_float64_split_directive (Int64.bits_of_float f) | Csymbol_address s -> add_used_symbol s; D.long (ConstLabel (emit_symbol s)) - | Clabel_address lbl -> D.long (ConstLabel (emit_data_label lbl)) | Cstring s -> D.bytes s | Cskip n -> if n > 0 then D.space n | Calign n -> D.align n @@ -1027,7 +1027,6 @@ let begin_assembly() = D.extrn "_caml_alloc3" PROC; D.extrn "_caml_ml_array_bound_error" PROC; D.extrn "_caml_raise_exn" PROC; - D.extrn "_caml_reraise_exn" PROC; end; D.data (); @@ -1057,7 +1056,8 @@ let end_assembly() = emit_global_label "frametable"; emit_frames - { efa_label = (fun l -> D.long (ConstLabel (emit_label l))); + { efa_code_label = (fun l -> D.long (ConstLabel (emit_label l))); + efa_data_label = (fun l -> D.long (ConstLabel (emit_label l))); efa_16 = (fun n -> D.word (const n)); efa_32 = (fun n -> D.long (const_32 n)); efa_word = (fun n -> D.long (const n)); diff --git a/asmcomp/i386/proc.ml b/asmcomp/i386/proc.ml index b7e17843..9350fc96 100644 --- a/asmcomp/i386/proc.ml +++ b/asmcomp/i386/proc.ml @@ -94,6 +94,8 @@ let edx = phys_reg 3 let stack_slot slot ty = Reg.at_location ty (Stack slot) +let loc_spacetime_node_hole = Reg.dummy (* Spacetime unsupported *) + (* Instruction selection *) let word_addressed = false @@ -140,7 +142,7 @@ let calling_conventions first_int last_int first_float last_float make_stack let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs -let not_supported ofs = fatal_error "Proc.loc_results: cannot call" +let not_supported _ofs = fatal_error "Proc.loc_results: cannot call" (* Six arguments in integer registers plus eight in global memory. *) let max_arguments_for_tailcalls = 14 @@ -148,16 +150,16 @@ let max_arguments_for_tailcalls = 14 let loc_arguments arg = calling_conventions 0 5 100 99 outgoing arg let loc_parameters arg = - let (loc, ofs) = calling_conventions 0 5 100 99 incoming arg in loc + let (loc, _ofs) = calling_conventions 0 5 100 99 incoming arg in loc let loc_results res = - let (loc, ofs) = calling_conventions 0 5 100 100 not_supported res in loc -let loc_external_arguments arg = + let (loc, _ofs) = calling_conventions 0 5 100 100 not_supported res in loc +let loc_external_arguments _arg = fatal_error "Proc.loc_external_arguments" let loc_external_results res = match res with | [|{typ=Int};{typ=Int}|] -> [|eax; edx|] | _ -> - let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc + let (loc, _ofs) = calling_conventions 0 0 100 100 not_supported res in loc let loc_exn_bucket = eax @@ -182,8 +184,9 @@ let destroyed_at_c_call = (* ebx, esi, edi, ebp preserved *) [|eax; ecx; edx|] let destroyed_at_oper = function - Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs - | Iop(Iextcall(_, false)) -> destroyed_at_c_call + Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; _}) -> + all_phys_regs + | Iop(Iextcall { alloc = false; }) -> destroyed_at_c_call | Iop(Iintop(Idiv | Imod)) -> [| eax; edx |] | Iop(Ialloc _ | Iintop Imulh) -> [| eax |] | Iop(Iintop(Icomp _) | Iintop_imm(Icomp _, _)) -> [| eax |] @@ -195,10 +198,10 @@ let destroyed_at_raise = all_phys_regs (* Maximal register pressure *) -let safe_register_pressure op = 4 +let safe_register_pressure _op = 4 let max_register_pressure = function - Iextcall(_, _) -> [| 4; max_int |] + Iextcall _ -> [| 4; max_int |] | Iintop(Idiv | Imod) -> [| 5; max_int |] | Ialloc _ | Iintop(Icomp _) | Iintop_imm(Icomp _, _) | Iintoffloat -> [| 6; max_int |] @@ -208,9 +211,9 @@ let max_register_pressure = function registers). *) let op_is_pure = function - | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _ | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ - | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> false + | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _) -> false | Ispecific(Ilea _) -> true | Ispecific _ -> false | _ -> true diff --git a/asmcomp/i386/reload.ml b/asmcomp/i386/reload.ml index 67f3e571..511b7f1b 100644 --- a/asmcomp/i386/reload.ml +++ b/asmcomp/i386/reload.ml @@ -40,7 +40,7 @@ method! makereg r = method! reload_operation op arg res = match op with - Iintop(Iadd|Isub|Iand|Ior|Ixor|Icomp _|Icheckbound) -> + Iintop(Iadd|Isub|Iand|Ior|Ixor|Icomp _|Icheckbound _) -> (* One of the two arguments can reside in the stack *) if stackp arg.(0) && stackp arg.(1) then ([|arg.(0); self#makereg arg.(1)|], res) @@ -71,7 +71,7 @@ method! reload_operation op arg res = method! reload_test tst arg = match tst with - Iinttest cmp -> + Iinttest _ -> (* One of the two arguments can reside on stack *) if stackp arg.(0) && stackp arg.(1) then [| self#makereg arg.(0); arg.(1) |] diff --git a/asmcomp/i386/selection.ml b/asmcomp/i386/selection.ml index f37781d2..16199ca6 100644 --- a/asmcomp/i386/selection.ml +++ b/asmcomp/i386/selection.ml @@ -88,7 +88,7 @@ let rec float_needs = function let n1 = float_needs arg1 in let n2 = float_needs arg2 in if n1 = n2 then 1 + n1 else if n1 > n2 then n1 else n2 - | Cop(Cextcall(fn, ty_res, alloc, dbg), args) + | Cop(Cextcall(fn, _ty_res, _alloc, _dbg, _label), args) when !fast_math && List.mem fn inline_float_ops -> begin match args with [arg] -> float_needs arg @@ -138,7 +138,7 @@ let pseudoregs_for_operation op arg res = (* For storing a byte, the argument must be in eax...edx. (But for a short, any reg will do!) Keep it simple, just force the argument to be in edx. *) - | Istore((Byte_unsigned | Byte_signed), addr, _) -> + | Istore((Byte_unsigned | Byte_signed), _, _) -> let newarg = Array.copy arg in newarg.(0) <- edx; (newarg, res, false) @@ -157,18 +157,18 @@ class selector = object (self) inherit Selectgen.selector_generic as super -method is_immediate (n : int) = true +method is_immediate (_n : int) = true method! is_simple_expr e = match e with - | Cop(Cextcall(fn, _, alloc, _), args) + | Cop(Cextcall(fn, _, _, _, _), args) when !fast_math && List.mem fn inline_float_ops -> (* inlined float ops are simple if their arguments are *) List.for_all self#is_simple_expr args | _ -> super#is_simple_expr e -method select_addressing chunk exp = +method select_addressing _chunk exp = match select_addr exp with (Asymbol s, d) -> (Ibased(s, d), Ctuple []) @@ -185,7 +185,7 @@ method! select_store is_assign addr exp = match exp with Cconst_int n -> (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple []) - | (Cconst_natint n | Cconst_blockheader n) -> + | (Cconst_natint n | Cblockheader (n, _)) -> (Ispecific(Istore_int(n, addr, is_assign)), Ctuple []) | Cconst_pointer n -> (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple []) @@ -201,7 +201,7 @@ method! select_operation op args = (* Recognize the LEA instruction *) Caddi | Caddv | Cadda | Csubi -> begin match self#select_addressing Word_int (Cop(op, args)) with - (Iindexed d, _) -> super#select_operation op args + (Iindexed _, _) | (Iindexed2 0, _) -> super#select_operation op args | (addr, arg) -> (Ispecific(Ilea addr), [arg]) end @@ -228,7 +228,7 @@ method! select_operation op args = super#select_operation op args end (* Recognize inlined floating point operations *) - | Cextcall(fn, ty_res, false, dbg) + | Cextcall(fn, _ty_res, false, _dbg, _label) when !fast_math && List.mem fn inline_float_ops -> (Ispecific(Ifloatspecial fn), args) (* i386 does not support immediate operands for multiply high signed *) diff --git a/asmcomp/import_approx.ml b/asmcomp/import_approx.ml index 34a0b85f..7b4fef9c 100644 --- a/asmcomp/import_approx.ml +++ b/asmcomp/import_approx.ml @@ -104,7 +104,11 @@ let rec import_ex ex = | Unknown_or_mutable -> A.value_mutable_float_array ~size:float_array.size | Contents contents -> - A.value_immutable_float_array contents + A.value_immutable_float_array + (Array.map (function + | None -> A.value_any_float + | Some f -> A.value_float f) + contents) end | Export_info.Value_boxed_int (t, i) -> A.value_boxed_int t i | Value_string { size; contents } -> diff --git a/asmcomp/interf.ml b/asmcomp/interf.ml index 2376aa21..28f00c11 100644 --- a/asmcomp/interf.ml +++ b/asmcomp/interf.ml @@ -90,17 +90,17 @@ let build_graph fundecl = | Iop(Imove | Ispill | Ireload) -> add_interf_move i.arg.(0) i.res.(0) i.live; interf i.next - | Iop(Itailcall_ind) -> () - | Iop(Itailcall_imm lbl) -> () - | Iop op -> + | Iop(Itailcall_ind _) -> () + | Iop(Itailcall_imm _) -> () + | Iop _ -> add_interf_set i.res i.live; add_interf_self i.res; interf i.next - | Iifthenelse(tst, ifso, ifnot) -> + | Iifthenelse(_tst, ifso, ifnot) -> interf ifso; interf ifnot; interf i.next - | Iswitch(index, cases) -> + | Iswitch(_index, cases) -> for i = 0 to Array.length cases - 1 do interf cases.(i) done; @@ -162,15 +162,15 @@ let build_graph fundecl = | Iop(Ireload) -> add_pref (weight / 4) i.res.(0) i.arg.(0); prefer weight i.next - | Iop(Itailcall_ind) -> () - | Iop(Itailcall_imm lbl) -> () - | Iop op -> + | Iop(Itailcall_ind _) -> () + | Iop(Itailcall_imm _) -> () + | Iop _ -> prefer weight i.next - | Iifthenelse(tst, ifso, ifnot) -> + | Iifthenelse(_tst, ifso, ifnot) -> prefer (weight / 2) ifso; prefer (weight / 2) ifnot; prefer weight i.next - | Iswitch(index, cases) -> + | Iswitch(_index, cases) -> for i = 0 to Array.length cases - 1 do prefer (weight / 2) cases.(i) done; diff --git a/asmcomp/linearize.ml b/asmcomp/linearize.ml index 7cf99fe1..44df185c 100644 --- a/asmcomp/linearize.ml +++ b/asmcomp/linearize.ml @@ -18,11 +18,7 @@ open Reg open Mach -type label = int - -let label_counter = ref 99 - -let new_label() = incr label_counter; !label_counter +type label = Cmm.label type instruction = { mutable desc: instruction_desc; @@ -45,18 +41,20 @@ and instruction_desc = | Lsetuptrap of label | Lpushtrap | Lpoptrap - | Lraise of Lambda.raise_kind + | Lraise of Cmm.raise_kind let has_fallthrough = function | Lreturn | Lbranch _ | Lswitch _ | Lraise _ - | Lop Itailcall_ind | Lop (Itailcall_imm _) -> false + | Lop Itailcall_ind _ | Lop (Itailcall_imm _) -> false | _ -> true type fundecl = { fun_name: string; fun_body: instruction; fun_fast: bool; - fun_dbg : Debuginfo.t } + fun_dbg : Debuginfo.t; + fun_spacetime_shape : Mach.spacetime_shape option; + } (* Invert a test *) @@ -113,7 +111,7 @@ let get_label n = match n.desc with Lbranch lbl -> (lbl, n) | Llabel lbl -> (lbl, n) | Lend -> (-1, n) - | _ -> let lbl = new_label() in (lbl, cons_instr (Llabel lbl) n) + | _ -> let lbl = Cmm.new_label() in (lbl, cons_instr (Llabel lbl) n) (* Check the fallthrough label *) let check_label n = match n.desc with @@ -180,8 +178,11 @@ let local_exit k = let rec linear i n = match i.Mach.desc with Iend -> n - | Iop(Itailcall_ind | Itailcall_imm _ as op) -> - copy_instr (Lop op) i (discard_dead_code n) + | Iop(Itailcall_ind _ | Itailcall_imm _ as op) -> + if not Config.spacetime then + copy_instr (Lop op) i (discard_dead_code n) + else + copy_instr (Lop op) i (linear i.Mach.next n) | Iop(Imove | Ireload | Ispill) when i.Mach.arg.(0).loc = i.Mach.res.(0).loc -> linear i.Mach.next n @@ -248,7 +249,7 @@ let rec linear i n = end else copy_instr (Lswitch(Array.map (fun n -> lbl_cases.(n)) index)) i !n2 | Iloop body -> - let lbl_head = new_label() in + let lbl_head = Cmm.new_label() in let n1 = linear i.Mach.next n in let n2 = linear body (cons_instr (Lbranch lbl_head) n1) in cons_instr (Llabel lbl_head) n2 @@ -280,21 +281,20 @@ let rec linear i n = | Itrywith(body, handler) -> let (lbl_join, n1) = get_label (linear i.Mach.next n) in incr try_depth; + assert (i.Mach.arg = [| |] || Config.spacetime); let (lbl_body, n2) = - get_label (cons_instr Lpushtrap + get_label (instr_cons Lpushtrap i.Mach.arg [| |] (linear body (cons_instr Lpoptrap n1))) in decr try_depth; - cons_instr (Lsetuptrap lbl_body) + instr_cons (Lsetuptrap lbl_body) i.Mach.arg [| |] (linear handler (add_branch lbl_join n2)) | Iraise k -> copy_instr (Lraise k) i (discard_dead_code n) -let reset () = - label_counter := 99; - exit_label := [] - let fundecl f = { fun_name = f.Mach.fun_name; fun_body = linear f.Mach.fun_body end_instr; fun_fast = f.Mach.fun_fast; - fun_dbg = f.Mach.fun_dbg } + fun_dbg = f.Mach.fun_dbg; + fun_spacetime_shape = f.Mach.fun_spacetime_shape; + } diff --git a/asmcomp/linearize.mli b/asmcomp/linearize.mli index 6d6d01cb..850fbd89 100644 --- a/asmcomp/linearize.mli +++ b/asmcomp/linearize.mli @@ -15,8 +15,7 @@ (* Transformation of Mach code into a list of pseudo-instructions. *) -type label = int -val new_label: unit -> label +type label = Cmm.label type instruction = { mutable desc: instruction_desc; @@ -39,7 +38,7 @@ and instruction_desc = | Lsetuptrap of label | Lpushtrap | Lpoptrap - | Lraise of Lambda.raise_kind + | Lraise of Cmm.raise_kind val has_fallthrough : instruction_desc -> bool val end_instr: instruction @@ -51,7 +50,8 @@ type fundecl = { fun_name: string; fun_body: instruction; fun_fast: bool; - fun_dbg : Debuginfo.t } + fun_dbg : Debuginfo.t; + fun_spacetime_shape : Mach.spacetime_shape option; + } -val reset : unit -> unit val fundecl: Mach.fundecl -> fundecl diff --git a/asmcomp/liveness.ml b/asmcomp/liveness.ml index 1ce943ab..c3d2f878 100644 --- a/asmcomp/liveness.ml +++ b/asmcomp/liveness.ml @@ -35,18 +35,24 @@ let rec live i finally = before the instruction sequence. The instruction i is annotated by the set of registers live across the instruction. *) + let arg = + if Config.spacetime + && Mach.spacetime_node_hole_pointer_is_live_before i + then Array.append i.arg [| Proc.loc_spacetime_node_hole |] + else i.arg + in match i.desc with Iend -> i.live <- finally; finally - | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> + | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) -> i.live <- Reg.Set.empty; (* no regs are live across *) - Reg.set_of_array i.arg + Reg.set_of_array arg | Iop op -> let after = live i.next finally in if Proc.op_is_pure op (* no side effects *) && Reg.disjoint_set_array after i.res (* results are not used after *) - && not (Proc.regs_are_volatile i.arg) (* no stack-like hard reg *) + && not (Proc.regs_are_volatile arg) (* no stack-like hard reg *) && not (Proc.regs_are_volatile i.res) (* is involved *) then begin (* This operation is dead code. Ignore its arguments. *) @@ -56,8 +62,8 @@ let rec live i finally = let across_after = Reg.diff_set_array after i.res in let across = match op with - | Icall_ind | Icall_imm _ | Iextcall _ - | Iintop Icheckbound | Iintop_imm(Icheckbound, _) -> + | Icall_ind _ | Icall_imm _ | Iextcall _ + | Iintop (Icheckbound _) | Iintop_imm(Icheckbound _, _) -> (* The function call may raise an exception, branching to the nearest enclosing try ... with. Similarly for bounds checks. Hence, everything that must be live at the beginning of @@ -66,21 +72,21 @@ let rec live i finally = | _ -> across_after in i.live <- across; - Reg.add_set_array across i.arg + Reg.add_set_array across arg end - | Iifthenelse(test, ifso, ifnot) -> + | Iifthenelse(_test, ifso, ifnot) -> let at_join = live i.next finally in let at_fork = Reg.Set.union (live ifso at_join) (live ifnot at_join) in i.live <- at_fork; - Reg.add_set_array at_fork i.arg - | Iswitch(index, cases) -> + Reg.add_set_array at_fork arg + | Iswitch(_index, cases) -> let at_join = live i.next finally in let at_fork = ref Reg.Set.empty in for i = 0 to Array.length cases - 1 do at_fork := Reg.Set.union !at_fork (live cases.(i) at_join) done; i.live <- !at_fork; - Reg.add_set_array !at_fork i.arg + Reg.add_set_array !at_fork arg | Iloop(body) -> let at_top = ref Reg.Set.empty in (* Yes, there are better algorithms, but we'll just iterate till @@ -120,7 +126,7 @@ let rec live i finally = before_body | Iraise _ -> i.live <- !live_at_raise; - Reg.add_set_array !live_at_raise i.arg + Reg.add_set_array !live_at_raise arg let reset () = live_at_raise := Reg.Set.empty; @@ -128,8 +134,13 @@ let reset () = let fundecl ppf f = let initially_live = live f.fun_body Reg.Set.empty in - (* Sanity check: only function parameters can be live at entrypoint *) + (* Sanity check: only function parameters (and the Spacetime node hole + register, if profiling) can be live at entrypoint *) let wrong_live = Reg.Set.diff initially_live (Reg.set_of_array f.fun_args) in + let wrong_live = + if not Config.spacetime then wrong_live + else Reg.Set.remove Proc.loc_spacetime_node_hole wrong_live + in if not (Reg.Set.is_empty wrong_live) then begin Format.fprintf ppf "%a@." Printmach.regset wrong_live; Misc.fatal_error "Liveness.fundecl" diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml index 0770b988..d1e0b3bd 100644 --- a/asmcomp/mach.ml +++ b/asmcomp/mach.ml @@ -15,6 +15,8 @@ (* Representation of machine code by sequences of pseudoinstructions *) +type label = Cmm.label + type integer_comparison = Isigned of Cmm.comparison | Iunsigned of Cmm.comparison @@ -23,7 +25,8 @@ type integer_operation = Iadd | Isub | Imul | Imulh | Idiv | Imod | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr | Icomp of integer_comparison - | Icheckbound + | Icheckbound of { label_after_error : label option; + spacetime_index : int; } type test = Itruetest @@ -41,16 +44,16 @@ type operation = | Iconst_int of nativeint | Iconst_float of int64 | Iconst_symbol of string - | Iconst_blockheader of nativeint - | Icall_ind - | Icall_imm of string - | Itailcall_ind - | Itailcall_imm of string - | Iextcall of string * bool + | Icall_ind of { label_after : label; } + | Icall_imm of { func : string; label_after : label; } + | Itailcall_ind of { label_after : label; } + | Itailcall_imm of { func : string; label_after : label; } + | Iextcall of { func : string; alloc : bool; label_after : label; } | Istackoffset of int | Iload of Cmm.memory_chunk * Arch.addressing_mode | Istore of Cmm.memory_chunk * Arch.addressing_mode * bool - | Ialloc of int + | Ialloc of { words : int; label_after_call_gc : label option; + spacetime_index : int; } | Iintop of integer_operation | Iintop_imm of integer_operation * int | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf @@ -75,14 +78,23 @@ and instruction_desc = | Icatch of int * instruction * instruction | Iexit of int | Itrywith of instruction * instruction - | Iraise of Lambda.raise_kind + | Iraise of Cmm.raise_kind + +type spacetime_part_of_shape = + | Direct_call_point of { callee : string; } + | Indirect_call_point + | Allocation_point + +type spacetime_shape = (spacetime_part_of_shape * Cmm.label) list type fundecl = { fun_name: string; fun_args: Reg.t array; fun_body: instruction; fun_fast: bool; - fun_dbg : Debuginfo.t } + fun_dbg : Debuginfo.t; + fun_spacetime_shape : spacetime_shape option; + } let rec dummy_instr = { desc = Iend; @@ -114,10 +126,10 @@ let rec instr_iter f i = f i; match i.desc with Iend -> () - | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> () - | Iifthenelse(tst, ifso, ifnot) -> + | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) -> () + | Iifthenelse(_tst, ifso, ifnot) -> instr_iter f ifso; instr_iter f ifnot; instr_iter f i.next - | Iswitch(index, cases) -> + | Iswitch(_index, cases) -> for i = 0 to Array.length cases - 1 do instr_iter f cases.(i) done; @@ -132,3 +144,36 @@ let rec instr_iter f i = | Iraise _ -> () | _ -> instr_iter f i.next + +let spacetime_node_hole_pointer_is_live_before insn = + match insn.desc with + | Iop op -> + begin match op with + | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _ -> true + | Iextcall { alloc; } -> alloc + | Ialloc _ -> + (* Allocations are special: the call to [caml_call_gc] requires some + instrumentation code immediately prior, but this is not inserted until + the emitter (since the call is not visible prior to that in any IR). + As such, none of the Mach / Linearize analyses will ever see that + we use the node hole pointer for these, and we do not need to say + that it is live at such points. *) + false + | Iintop op | Iintop_imm (op, _) -> + begin match op with + | Icheckbound _ + (* [Icheckbound] doesn't need to return [true] for the same reason as + [Ialloc]. *) + | Iadd | Isub | Imul | Imulh | Idiv | Imod + | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr + | Icomp _ -> false + end + | Ispecific specific_op -> + Arch.spacetime_node_hole_pointer_is_live_before specific_op + | Imove | Ispill | Ireload | Iconst_int _ | Iconst_float _ + | Iconst_symbol _ | Istackoffset _ | Iload _ | Istore _ + | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf + | Ifloatofint | Iintoffloat -> false + end + | Iend | Ireturn | Iifthenelse _ | Iswitch _ | Iloop _ | Icatch _ + | Iexit _ | Itrywith _ | Iraise _ -> false diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli index d3d912d2..798e314f 100644 --- a/asmcomp/mach.mli +++ b/asmcomp/mach.mli @@ -15,6 +15,12 @@ (* Representation of machine code by sequences of pseudoinstructions *) +(** N.B. Backends vary in their treatment of call gc and checkbound + points. If the positioning of any labels associated with these is + important for some new feature in the compiler, the relevant backends' + behaviour should be checked. *) +type label = Cmm.label + type integer_comparison = Isigned of Cmm.comparison | Iunsigned of Cmm.comparison @@ -23,7 +29,11 @@ type integer_operation = Iadd | Isub | Imul | Imulh | Idiv | Imod | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr | Icomp of integer_comparison - | Icheckbound + | Icheckbound of { label_after_error : label option; + spacetime_index : int; } + (** For Spacetime only, [Icheckbound] operations take two arguments, the + second being the pointer to the trie node for the current function + (and the first being as per non-Spacetime mode). *) type test = Itruetest @@ -41,17 +51,19 @@ type operation = | Iconst_int of nativeint | Iconst_float of int64 | Iconst_symbol of string - | Iconst_blockheader of nativeint - | Icall_ind - | Icall_imm of string - | Itailcall_ind - | Itailcall_imm of string - | Iextcall of string * bool (* false = noalloc, true = alloc *) + | Icall_ind of { label_after : label; } + | Icall_imm of { func : string; label_after : label; } + | Itailcall_ind of { label_after : label; } + | Itailcall_imm of { func : string; label_after : label; } + | Iextcall of { func : string; alloc : bool; label_after : label; } | Istackoffset of int | Iload of Cmm.memory_chunk * Arch.addressing_mode | Istore of Cmm.memory_chunk * Arch.addressing_mode * bool (* false = initialization, true = assignment *) - | Ialloc of int + | Ialloc of { words : int; label_after_call_gc : label option; + spacetime_index : int; } + (** For Spacetime only, Ialloc instructions take one argument, being the + pointer to the trie node for the current function. *) | Iintop of integer_operation | Iintop_imm of integer_operation * int | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf @@ -76,14 +88,29 @@ and instruction_desc = | Icatch of int * instruction * instruction | Iexit of int | Itrywith of instruction * instruction - | Iraise of Lambda.raise_kind + | Iraise of Cmm.raise_kind + +type spacetime_part_of_shape = + | Direct_call_point of { callee : string; (* the symbol *) } + | Indirect_call_point + | Allocation_point + +(** A description of the layout of a Spacetime profiling node associated with + a given function. Each call and allocation point instrumented within + the function is marked with a label in the code and assigned a place + within the node. This information is stored within the executable and + extracted when the user saves a profile. The aim is to minimise runtime + memory usage within the nodes and increase performance. *) +type spacetime_shape = (spacetime_part_of_shape * Cmm.label) list type fundecl = { fun_name: string; fun_args: Reg.t array; fun_body: instruction; fun_fast: bool; - fun_dbg : Debuginfo.t } + fun_dbg : Debuginfo.t; + fun_spacetime_shape : spacetime_shape option; + } val dummy_instr: instruction val end_instr: unit -> instruction @@ -94,3 +121,5 @@ val instr_cons_debug: instruction_desc -> Reg.t array -> Reg.t array -> Debuginfo.t -> instruction -> instruction val instr_iter: (instruction -> unit) -> instruction -> unit + +val spacetime_node_hole_pointer_is_live_before : instruction -> bool diff --git a/asmcomp/power/CSE.ml b/asmcomp/power/CSE.ml index 3106bdd8..b8454ffd 100644 --- a/asmcomp/power/CSE.ml +++ b/asmcomp/power/CSE.ml @@ -19,7 +19,7 @@ open Arch open Mach open CSEgen -class cse = object (self) +class cse = object inherit cse_generic as super @@ -31,7 +31,7 @@ method! class_of_operation op = method! is_cheap_operation op = match op with - | Iconst_int n | Iconst_blockheader n -> n <= 32767n && n >= -32768n + | Iconst_int n -> n <= 32767n && n >= -32768n | _ -> false end diff --git a/asmcomp/power/arch.ml b/asmcomp/power/arch.ml index 2e7d19ca..289f33ca 100644 --- a/asmcomp/power/arch.ml +++ b/asmcomp/power/arch.ml @@ -46,7 +46,15 @@ let command_line_options = [ type specific_operation = Imultaddf (* multiply and add *) | Imultsubf (* multiply and subtract *) - | Ialloc_far of int (* allocation in large functions *) + | Ialloc_far of (* allocation in large functions *) + { words : int; label_after_call_gc : int (*Cmm.label*) option; } + +(* note: we avoid introducing a dependency to Cmm since this dep + is not detected when "make depend" is run under amd64 *) + +let spacetime_node_hole_pointer_is_live_before = function + | Imultaddf | Imultsubf -> false + | Ialloc_far _ -> true (* Addressing modes *) @@ -85,8 +93,8 @@ let offset_addressing addr delta = | Iindexed2 -> assert false let num_args_addressing = function - Ibased(s, n) -> 0 - | Iindexed n -> 1 + Ibased _ -> 0 + | Iindexed _ -> 1 | Iindexed2 -> 2 (* Printing operations and addressing modes *) @@ -110,5 +118,5 @@ let print_specific_operation printreg op ppf arg = | Imultsubf -> fprintf ppf "%a *f %a -f %a" printreg arg.(0) printreg arg.(1) printreg arg.(2) - | Ialloc_far n -> - fprintf ppf "alloc_far %d" n + | Ialloc_far { words; _ } -> + fprintf ppf "alloc_far %d" words diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp index c9b26e85..d8bc1bf0 100644 --- a/asmcomp/power/emit.mlp +++ b/asmcomp/power/emit.mlp @@ -1,3 +1,4 @@ +#2 "asmcomp/power/emit.mlp" (**************************************************************************) (* *) (* OCaml *) @@ -82,9 +83,6 @@ let label_prefix = ".L" let emit_label lbl = emit_string label_prefix; emit_int lbl -let emit_data_label lbl = - emit_string label_prefix; emit_string "d"; emit_int lbl - (* Section switching *) let code_space = @@ -116,7 +114,6 @@ let datag = if ppc64 then ".quad" else ".long" let mullg = if ppc64 then "mulld" else "mullw" let divg = if ppc64 then "divd" else "divw" let tglle = if ppc64 then "tdlle" else "twlle" -let slgi = if ppc64 then "sldi" else "slwi" (* Output a processor register *) @@ -303,8 +300,12 @@ let adjust_stack_offset delta = (* Record live pointers at call points *) -let record_frame live dbg = - let lbl = new_label() in +let record_frame ?label live raise_ dbg = + let lbl = + match label with + | None -> new_label() + | Some label -> label + in let live_offset = ref [] in Reg.Set.iter (function @@ -320,6 +321,7 @@ let record_frame live dbg = { fd_lbl = lbl; fd_frame_size = frame_size(); fd_live_offset = !live_offset; + fd_raise = raise_; fd_debuginfo = dbg } :: !frame_descriptors; `{emit_label lbl}:\n` @@ -422,17 +424,17 @@ module BR = Branch_relaxation.Make (struct let size = match abi with - | ELF32 -> (fun a b c -> a) - | ELF64v1 -> (fun a b c -> b) - | ELF64v2 -> (fun a b c -> c) + | ELF32 -> (fun a _ _ -> a) + | ELF64v1 -> (fun _ b _ -> b) + | ELF64v2 -> (fun _ _ c -> c) let tocload_size() = if !big_toc || !Clflags.for_package <> None then 2 else 1 let load_store_size = function - | Ibased(s, d) -> + | Ibased(_s, d) -> if abi = ELF32 then 2 else begin - let (lo, hi) = low_high_s d in + let (_lo, hi) = low_high_s d in tocload_size() + (if hi = 0 then 1 else 2) end | Iindexed ofs -> if is_immediate ofs then 1 else 3 @@ -441,63 +443,65 @@ module BR = Branch_relaxation.Make (struct let instr_size = function | Lend -> 0 | Lop(Imove | Ispill | Ireload) -> 1 - | Lop(Iconst_int n | Iconst_blockheader n) -> + | Lop(Iconst_int n) -> if is_native_immediate n then 1 - else if (let (lo, hi) = native_low_high_s n in + else if (let (_lo, hi) = native_low_high_s n in hi >= -0x8000 && hi <= 0x7FFF) then 2 - else if (let (lo, hi) = native_low_high_u n in + else if (let (_lo, hi) = native_low_high_u n in hi >= -0x8000 && hi <= 0x7FFF) then 2 else tocload_size() - | Lop(Iconst_float s) -> if abi = ELF32 then 2 else tocload_size() - | Lop(Iconst_symbol s) -> if abi = ELF32 then 2 else tocload_size() - | Lop(Icall_ind) -> size 2 5 4 - | Lop(Icall_imm s) -> size 1 3 3 - | Lop(Itailcall_ind) -> size 5 7 6 - | Lop(Itailcall_imm s) -> - if s = !function_name + | Lop(Iconst_float _) -> if abi = ELF32 then 2 else tocload_size() + | Lop(Iconst_symbol _) -> if abi = ELF32 then 2 else tocload_size() + | Lop(Icall_ind _) -> size 2 5 4 + | Lop(Icall_imm _) -> size 1 3 3 + | Lop(Itailcall_ind _) -> size 5 7 6 + | Lop(Itailcall_imm { func; _ }) -> + if func = !function_name then 1 else size 4 (7 + tocload_size()) (6 + tocload_size()) - | Lop(Iextcall(s, true)) -> size 3 (2 + tocload_size()) (2 + tocload_size()) - | Lop(Iextcall(s, false)) -> size 1 2 2 - | Lop(Istackoffset n) -> 1 + | Lop(Iextcall { alloc = true; _ }) -> + size 3 (2 + tocload_size()) (2 + tocload_size()) + | Lop(Iextcall { alloc = false; _}) -> size 1 2 2 + | Lop(Istackoffset _) -> 1 | Lop(Iload(chunk, addr)) -> if chunk = Byte_signed then load_store_size addr + 1 else load_store_size addr - | Lop(Istore(chunk, addr, _)) -> load_store_size addr - | Lop(Ialloc n) -> 4 - | Lop(Ispecific(Ialloc_far n)) -> 5 + | Lop(Istore(_chunk, addr, _)) -> load_store_size addr + | Lop(Ialloc _) -> 4 + | Lop(Ispecific(Ialloc_far _)) -> 5 | Lop(Iintop Imod) -> 3 - | Lop(Iintop(Icomp cmp)) -> 4 - | Lop(Iintop op) -> 1 - | Lop(Iintop_imm(Icomp cmp, n)) -> 4 - | Lop(Iintop_imm(op, n)) -> 1 + | Lop(Iintop(Icomp _)) -> 4 + | Lop(Iintop _) -> 1 + | Lop(Iintop_imm(Icomp _, _)) -> 4 + | Lop(Iintop_imm _) -> 1 | Lop(Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf) -> 1 | Lop(Ifloatofint) -> 9 | Lop(Iintoffloat) -> 4 - | Lop(Ispecific sop) -> 1 + | Lop(Ispecific _) -> 1 | Lreloadretaddr -> 2 | Lreturn -> 2 - | Llabel lbl -> 0 - | Lbranch lbl -> 1 - | Lcondbranch(tst, lbl) -> 2 + | Llabel _ -> 0 + | Lbranch _ -> 1 + | Lcondbranch _ -> 2 | Lcondbranch3(lbl0, lbl1, lbl2) -> 1 + (if lbl0 = None then 0 else 1) + (if lbl1 = None then 0 else 1) + (if lbl2 = None then 0 else 1) - | Lswitch jumptbl -> size 7 (5 + tocload_size()) (5 + tocload_size()) - | Lsetuptrap lbl -> size 1 2 2 + | Lswitch _ -> size 7 (5 + tocload_size()) (5 + tocload_size()) + | Lsetuptrap _ -> size 1 2 2 | Lpushtrap -> size 4 5 5 | Lpoptrap -> 2 | Lraise _ -> 6 - let relax_allocation ~num_words = Lop (Ispecific (Ialloc_far num_words)) + let relax_allocation ~num_words:words ~label_after_call_gc = + Lop (Ispecific (Ialloc_far { words; label_after_call_gc; })) (* [classify_addr], above, never identifies these instructions as needing relaxing. As such, these functions should never be called. *) let relax_specific_op _ = assert false - let relax_intop_checkbound () = assert false - let relax_intop_imm_checkbound ~bound:_ = assert false + let relax_intop_checkbound ~label_after_error:_ = assert false + let relax_intop_imm_checkbound ~bound:_ ~label_after_error:_ = assert false end) (* Output the assembly code for an instruction *) @@ -510,22 +514,22 @@ let emit_instr i = let src = i.arg.(0) and dst = i.res.(0) in if src.loc <> dst.loc then begin match (src, dst) with - | {loc = Reg rs; typ = (Val | Int | Addr)}, {loc = Reg rd} -> + | {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Reg _} -> ` mr {emit_reg dst}, {emit_reg src}\n` - | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} -> + | {loc = Reg _; typ = Float}, {loc = Reg _; typ = Float} -> ` fmr {emit_reg dst}, {emit_reg src}\n` - | {loc = Reg rs; typ = (Val | Int | Addr)}, {loc = Stack sd} -> + | {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Stack _} -> ` {emit_string stg} {emit_reg src}, {emit_stack dst}\n` - | {loc = Reg rs; typ = Float}, {loc = Stack sd} -> + | {loc = Reg _; typ = Float}, {loc = Stack _} -> ` stfd {emit_reg src}, {emit_stack dst}\n` - | {loc = Stack ss; typ = (Val | Int | Addr)}, {loc = Reg rd} -> + | {loc = Stack _; typ = (Val | Int | Addr)}, {loc = Reg _} -> ` {emit_string lg} {emit_reg dst}, {emit_stack src}\n` - | {loc = Stack ss; typ = Float}, {loc = Reg rd} -> + | {loc = Stack _; typ = Float}, {loc = Reg _} -> ` lfd {emit_reg dst}, {emit_stack src}\n` | (_, _) -> fatal_error "Emit: Imove" end - | Lop(Iconst_int n | Iconst_blockheader n) -> + | Lop(Iconst_int n) -> if is_native_immediate n then ` li {emit_reg i.res.(0)}, {emit_nativeint n}\n` else begin @@ -574,31 +578,31 @@ let emit_instr i = | ELF64v1 | ELF64v2 -> emit_tocload emit_reg i.res.(0) (TocSym s) end - | Lop(Icall_ind) -> + | Lop(Icall_ind { label_after; }) -> begin match abi with | ELF32 -> ` mtctr {emit_reg i.arg.(0)}\n`; ` bctrl\n`; - record_frame i.live i.dbg + record_frame i.live false i.dbg ~label:label_after | ELF64v1 -> ` ld 0, 0({emit_reg i.arg.(0)})\n`; (* code pointer *) ` mtctr 0\n`; ` ld 2, 8({emit_reg i.arg.(0)})\n`; (* TOC for callee *) ` bctrl\n`; - record_frame i.live i.dbg; + record_frame i.live false i.dbg ~label:label_after; emit_reload_toc() | ELF64v2 -> ` mtctr {emit_reg i.arg.(0)}\n`; ` mr 12, {emit_reg i.arg.(0)}\n`; (* addr of fn in r12 *) ` bctrl\n`; - record_frame i.live i.dbg; + record_frame i.live false i.dbg ~label:label_after; emit_reload_toc() end - | Lop(Icall_imm s) -> + | Lop(Icall_imm { func; label_after; }) -> begin match abi with | ELF32 -> - emit_call s; - record_frame i.live i.dbg + emit_call func; + record_frame i.live false i.dbg ~label:label_after | ELF64v1 | ELF64v2 -> (* For PPC64, we cannot just emit a "bl s; nop" sequence, because of the following scenario: @@ -617,12 +621,12 @@ let emit_instr i = by the linker, but this is harmless. Cost: 3 instructions if same TOC, 7 if different TOC. Let's try option 2. *) - emit_call s; - record_frame i.live i.dbg; + emit_call func; + record_frame i.live false i.dbg ~label:label_after; ` nop\n`; emit_reload_toc() end - | Lop(Itailcall_ind) -> + | Lop(Itailcall_ind { label_after = _; }) -> begin match abi with | ELF32 -> ` mtctr {emit_reg i.arg.(0)}\n` @@ -640,20 +644,20 @@ let emit_instr i = end; emit_free_frame(); ` bctr\n` - | Lop(Itailcall_imm s) -> - if s = !function_name then + | Lop(Itailcall_imm { func; label_after = _; }) -> + if func = !function_name then ` b {emit_label !tailrec_entry_point}\n` else begin begin match abi with | ELF32 -> () | ELF64v1 -> - emit_tocload emit_gpr 11 (TocSym s); + emit_tocload emit_gpr 11 (TocSym func); ` ld 0, 0(11)\n`; (* code pointer *) ` mtctr 0\n`; ` ld 2, 8(11)\n` (* TOC for callee *) | ELF64v2 -> - emit_tocload emit_gpr 12 (TocSym s); (* addr of fn must be in r12 *) + emit_tocload emit_gpr 12 (TocSym func); (* addr of fn must be in r12 *) ` mtctr 12\n` end; if !contains_calls then begin @@ -663,26 +667,26 @@ let emit_instr i = emit_free_frame(); begin match abi with | ELF32 -> - ` b {emit_symbol s}\n` + ` b {emit_symbol func}\n` | ELF64v1 | ELF64v2 -> ` bctr\n` end end - | Lop(Iextcall(s, alloc)) -> + | Lop(Iextcall { func; alloc; }) -> if not alloc then begin - emit_call s; + emit_call func; emit_call_nop() end else begin match abi with | ELF32 -> - ` addis 28, 0, {emit_upper emit_symbol s}\n`; - ` addi 28, 28, {emit_lower emit_symbol s}\n`; + ` addis 28, 0, {emit_upper emit_symbol func}\n`; + ` addi 28, 28, {emit_lower emit_symbol func}\n`; emit_call "caml_c_call"; - record_frame i.live i.dbg + record_frame i.live false i.dbg | ELF64v1 | ELF64v2 -> - emit_tocload emit_gpr 28 (TocSym s); + emit_tocload emit_gpr 28 (TocSym func); emit_call "caml_c_call"; - record_frame i.live i.dbg; + record_frame i.live false i.dbg; ` nop\n` end | Lop(Istackoffset n) -> @@ -713,23 +717,31 @@ let emit_instr i = | Single -> "stfs" | Double | Double_u -> "stfd" in emit_load_store storeinstr addr i.arg 1 i.arg.(0) - | Lop(Ialloc n) -> - if !call_gc_label = 0 then call_gc_label := new_label(); + | Lop(Ialloc { words = n; label_after_call_gc; }) -> + if !call_gc_label = 0 then begin + match label_after_call_gc with + | None -> call_gc_label := new_label () + | Some label -> call_gc_label := label + end; ` addi 31, 31, {emit_int(-n)}\n`; ` {emit_string cmplg} 31, 30\n`; ` addi {emit_reg i.res.(0)}, 31, {emit_int size_addr}\n`; ` bltl {emit_label !call_gc_label}\n`; (* Exactly 4 instructions after the beginning of the alloc sequence *) - record_frame i.live Debuginfo.none - | Lop(Ispecific(Ialloc_far n)) -> - if !call_gc_label = 0 then call_gc_label := new_label(); + record_frame i.live false Debuginfo.none + | Lop(Ispecific(Ialloc_far { words = n; label_after_call_gc; })) -> + if !call_gc_label = 0 then begin + match label_after_call_gc with + | None -> call_gc_label := new_label () + | Some label -> call_gc_label := label + end; let lbl = new_label() in ` addi 31, 31, {emit_int(-n)}\n`; ` {emit_string cmplg} 31, 30\n`; ` bge {emit_label lbl}\n`; ` bl {emit_label !call_gc_label}\n`; (* Exactly 4 instructions after the beginning of the alloc sequence *) - record_frame i.live Debuginfo.none; + record_frame i.live false Debuginfo.none; `{emit_label lbl}: addi {emit_reg i.res.(0)}, 31, {emit_int size_addr}\n` | Lop(Iintop Isub) -> (* subfc has swapped arguments *) ` subfc {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n` @@ -746,9 +758,9 @@ let emit_instr i = ` {emit_string cmplg} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; emit_set_comp c i.res.(0) end - | Lop(Iintop Icheckbound) -> + | Lop(Iintop (Icheckbound { label_after_error; })) -> if !Clflags.debug then - record_frame Reg.Set.empty i.dbg; + record_frame Reg.Set.empty false i.dbg ?label:label_after_error; ` {emit_string tglle} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` | Lop(Iintop op) -> let instr = name_for_intop op in @@ -764,9 +776,9 @@ let emit_instr i = ` {emit_string cmplg}i {emit_reg i.arg.(0)}, {emit_int n}\n`; emit_set_comp c i.res.(0) end - | Lop(Iintop_imm(Icheckbound, n)) -> + | Lop(Iintop_imm(Icheckbound { label_after_error; }, n)) -> if !Clflags.debug then - record_frame Reg.Set.empty i.dbg; + record_frame Reg.Set.empty false i.dbg ?label:label_after_error; ` {emit_string tglle}i {emit_reg i.arg.(0)}, {emit_int n}\n` | Lop(Iintop_imm(op, n)) -> let instr = name_for_intop_imm op in @@ -931,17 +943,12 @@ let emit_instr i = ` addi 1, 1, {emit_int trap_size}\n`; adjust_stack_offset (-trap_size) | Lraise k -> - begin match !Clflags.debug, k with - | true, Lambda.Raise_regular -> + begin match k with + | Cmm.Raise_withtrace -> emit_call "caml_raise_exn"; - record_frame Reg.Set.empty i.dbg; - emit_call_nop() - | true, Lambda.Raise_reraise -> - emit_call "caml_reraise_exn"; - record_frame Reg.Set.empty i.dbg; + record_frame Reg.Set.empty true i.dbg; emit_call_nop() - | false, _ - | true, Lambda.Raise_notrace -> + | Cmm.Raise_notrace -> ` {emit_string lg} 0, {emit_int trap_handler_offset}(29)\n`; ` mr 1, 29\n`; ` mtctr 0\n`; @@ -1099,8 +1106,6 @@ let emit_item = function declare_global_data s | Cdefine_symbol s -> `{emit_symbol s}:\n`; - | Cdefine_label lbl -> - `{emit_data_label lbl}:\n` | Cint8 n -> ` .byte {emit_int n}\n` | Cint16 n -> @@ -1117,8 +1122,6 @@ let emit_item = function else emit_float64_split_directive ".long" (Int64.bits_of_float f) | Csymbol_address s -> ` {emit_string datag} {emit_symbol s}\n` - | Clabel_address lbl -> - ` {emit_string datag} {emit_data_label lbl}\n` | Cstring s -> emit_bytes_directive " .byte " s | Cskip n -> @@ -1202,7 +1205,10 @@ let end_assembly() = declare_global_data lbl; `{emit_symbol lbl}:\n`; emit_frames - { efa_label = (fun l -> ` {emit_string datag} {emit_label l}\n`); + { efa_code_label = + (fun l -> ` {emit_string datag} {emit_label l}\n`); + efa_data_label = + (fun l -> ` {emit_string datag} {emit_label l}\n`); efa_16 = (fun n -> ` .short {emit_int n}\n`); efa_32 = (fun n -> ` .long {emit_int32 n}\n`); efa_word = (fun n -> ` {emit_string datag} {emit_int n}\n`); diff --git a/asmcomp/power/proc.ml b/asmcomp/power/proc.ml index feb66a26..670e8495 100644 --- a/asmcomp/power/proc.ml +++ b/asmcomp/power/proc.ml @@ -90,6 +90,8 @@ let phys_reg n = let stack_slot slot ty = Reg.at_location ty (Stack slot) +let loc_spacetime_node_hole = Reg.dummy (* Spacetime unsupported *) + (* Calling conventions *) let calling_conventions @@ -167,7 +169,7 @@ let calling_conventions let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs -let not_supported ofs = fatal_error "Proc.loc_results: cannot call" +let not_supported _ofs = fatal_error "Proc.loc_results: cannot call" let single_regs arg = Array.map (fun arg -> [| arg |]) arg let ensure_single_regs res = @@ -184,12 +186,12 @@ let loc_arguments arg = in (ensure_single_regs loc, ofs) let loc_parameters arg = - let (loc, ofs) = + let (loc, _ofs) = calling_conventions 0 7 100 112 incoming 0 false (single_regs arg) in ensure_single_regs loc let loc_results res = - let (loc, ofs) = + let (loc, _ofs) = calling_conventions 0 7 100 112 not_supported 0 false (single_regs res) in ensure_single_regs loc @@ -243,12 +245,10 @@ let loc_external_arguments = then (loc, ofs) else (loc, 0) -let extcall_use_push = false - (* Results are in GPR 3 and FPR 1 *) let loc_external_results res = - let (loc, ofs) = + let (loc, _ofs) = calling_conventions 0 1 100 100 not_supported 0 false (single_regs res) in ensure_single_regs loc @@ -259,7 +259,7 @@ let loc_exn_bucket = phys_reg 0 (* Volatile registers: none *) -let regs_are_volatile rs = false +let regs_are_volatile _rs = false (* Registers destroyed by operations *) @@ -269,8 +269,9 @@ let destroyed_at_c_call = 100; 101; 102; 103; 104; 105; 106; 107; 108; 109; 110; 111; 112]) let destroyed_at_oper = function - Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs - | Iop(Iextcall(_, false)) -> destroyed_at_c_call + Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; _ }) -> + all_phys_regs + | Iop(Iextcall { alloc = false; _ }) -> destroyed_at_c_call | _ -> [||] let destroyed_at_raise = all_phys_regs @@ -278,20 +279,20 @@ let destroyed_at_raise = all_phys_regs (* Maximal register pressure *) let safe_register_pressure = function - Iextcall(_, _) -> 15 + Iextcall _ -> 15 | _ -> 23 let max_register_pressure = function - Iextcall(_, _) -> [| 15; 18 |] + Iextcall _ -> [| 15; 18 |] | _ -> [| 23; 30 |] (* Pure operations (without any side effect besides updating their result registers). *) let op_is_pure = function - | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _ | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ - | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> false + | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _) -> false | Ispecific(Imultaddf | Imultsubf) -> true | Ispecific _ -> false | _ -> true diff --git a/asmcomp/power/scheduling.ml b/asmcomp/power/scheduling.ml index 14f2ed81..dcbfca79 100644 --- a/asmcomp/power/scheduling.ml +++ b/asmcomp/power/scheduling.ml @@ -38,7 +38,7 @@ method oper_latency = function | Ispecific(Imultaddf | Imultsubf) -> 5 | _ -> 1 -method reload_retaddr_latency = 12 +method! reload_retaddr_latency = 12 (* If we can have that many cycles between the reloadretaddr and the return, we can expect that the blr branch will be completely folded. *) @@ -56,7 +56,7 @@ method oper_issue_cycles = function | Iintoffloat -> 4 | _ -> 1 -method reload_retaddr_issue_cycles = 3 +method! reload_retaddr_issue_cycles = 3 (* load then stalling mtlr *) end diff --git a/asmcomp/power/selection.ml b/asmcomp/power/selection.ml index c7ef00c5..71c47490 100644 --- a/asmcomp/power/selection.ml +++ b/asmcomp/power/selection.ml @@ -51,7 +51,7 @@ inherit Selectgen.selector_generic as super method is_immediate n = (n <= 32767) && (n >= -32768) -method select_addressing chunk exp = +method select_addressing _chunk exp = match select_addr exp with (Asymbol s, d) -> (Ibased(s, d), Ctuple []) diff --git a/asmcomp/printclambda.ml b/asmcomp/printclambda.ml index ba0c6462..c4a790a2 100644 --- a/asmcomp/printclambda.ml +++ b/asmcomp/printclambda.ml @@ -18,6 +18,20 @@ open Format open Asttypes open Clambda +let mutable_flag = function + | Mutable-> "[mut]" + | Immutable -> "" + +let value_kind = + let open Lambda in + function + | Pgenval -> "" + | Pintval -> ":int" + | Pfloatval -> ":float" + | Pboxedintval Pnativeint -> ":nativeint" + | Pboxedintval Pint32 -> ":int32" + | Pboxedintval Pint64 -> ":int64" + let rec structured_constant ppf = function | Uconst_float x -> fprintf ppf "%F" x | Uconst_int32 x -> fprintf ppf "%ldl" x @@ -78,13 +92,15 @@ and lam ppf = function List.iter (fprintf ppf "@ %a" lam) in fprintf ppf "@[<2>(closure@ %a %a)@]" funs clos lams fv | Uoffset(l,i) -> fprintf ppf "@[<2>(offset %a %d)@]" lam l i - | Ulet(id, arg, body) -> + | Ulet(mut, kind, id, arg, body) -> let rec letbody ul = match ul with - | Ulet(id, arg, body) -> - fprintf ppf "@ @[<2>%a@ %a@]" Ident.print id lam arg; + | Ulet(mut, kind, id, arg, body) -> + fprintf ppf "@ @[<2>%a%s%s@ %a@]" + Ident.print id (mutable_flag mut) (value_kind kind) lam arg; letbody body | _ -> ul in - fprintf ppf "@[<2>(let@ @[(@[<2>%a@ %a@]" Ident.print id lam arg; + fprintf ppf "@[<2>(let@ @[(@[<2>%a%s%s@ %a@]" + Ident.print id (mutable_flag mut) (value_kind kind) lam arg; let expr = letbody body in fprintf ppf ")@]@ %a)@]" lam expr | Uletrec(id_arg_list, body) -> diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml index b97f5370..21823e31 100644 --- a/asmcomp/printcmm.ml +++ b/asmcomp/printcmm.ml @@ -53,12 +53,16 @@ let chunk = function | Double -> "float64" | Double_u -> "float64u" +let raise_kind fmt = function + | Raise_withtrace -> Format.fprintf fmt "raise_withtrace" + | Raise_notrace -> Format.fprintf fmt "raise_notrace" + let operation = function - | Capply(ty, d) -> "app" ^ Debuginfo.to_string d - | Cextcall(lbl, ty, alloc, d) -> + | Capply(_ty, d) -> "app" ^ Debuginfo.to_string d + | Cextcall(lbl, _ty, _alloc, d, _) -> Printf.sprintf "extcall \"%s\"%s" lbl (Debuginfo.to_string d) | Cload c -> Printf.sprintf "load %s" (chunk c) - | Calloc -> "alloc" + | Calloc d -> "alloc" ^ Debuginfo.to_string d | Cstore (c, init) -> let init = match init with @@ -91,13 +95,16 @@ let operation = function | Cfloatofint -> "floatofint" | Cintoffloat -> "intoffloat" | Ccmpf c -> Printf.sprintf "%sf" (comparison c) - | Craise (k, d) -> Lambda.raise_kind k ^ Debuginfo.to_string d + | Craise (k, d) -> Format.asprintf "%a%s" raise_kind k (Debuginfo.to_string d) | Ccheckbound d -> "checkbound" ^ Debuginfo.to_string d let rec expr ppf = function | Cconst_int n -> fprintf ppf "%i" n - | Cconst_natint n | Cconst_blockheader n -> + | Cconst_natint n -> fprintf ppf "%s" (Nativeint.to_string n) + | Cblockheader(n, d) -> + fprintf ppf "block-hdr(%s)%s" + (Nativeint.to_string n) (Debuginfo.to_string d) | Cconst_float n -> fprintf ppf "%F" n | Cconst_symbol s -> fprintf ppf "\"%s\"" s | Cconst_pointer n -> fprintf ppf "%ia" n @@ -134,7 +141,7 @@ let rec expr ppf = function List.iter (fun e -> fprintf ppf "@ %a" expr e) el; begin match op with | Capply (mty, _) -> fprintf ppf "@ %a" machtype mty - | Cextcall(_, mty, _, _) -> fprintf ppf "@ %a" machtype mty + | Cextcall(_, mty, _, _, _) -> fprintf ppf "@ %a" machtype mty | _ -> () end; fprintf ppf ")@]" @@ -191,7 +198,6 @@ let fundecl ppf f = let data_item ppf = function | Cdefine_symbol s -> fprintf ppf "\"%s\":" s - | Cdefine_label l -> fprintf ppf "L%i:" l | Cglobal_symbol s -> fprintf ppf "global \"%s\"" s | Cint8 n -> fprintf ppf "byte %i" n | Cint16 n -> fprintf ppf "int16 %i" n @@ -200,7 +206,6 @@ let data_item ppf = function | Csingle f -> fprintf ppf "single %F" f | Cdouble f -> fprintf ppf "double %F" f | Csymbol_address s -> fprintf ppf "addr \"%s\"" s - | Clabel_address l -> fprintf ppf "addr L%i" l | Cstring s -> fprintf ppf "string \"%s\"" s | Cskip n -> fprintf ppf "skip %i" n | Calign n -> fprintf ppf "align %i" n diff --git a/asmcomp/printcmm.mli b/asmcomp/printcmm.mli index 31145e65..86ec11fe 100644 --- a/asmcomp/printcmm.mli +++ b/asmcomp/printcmm.mli @@ -26,3 +26,4 @@ val expression : formatter -> Cmm.expression -> unit val fundecl : formatter -> Cmm.fundecl -> unit val data : formatter -> Cmm.data_item list -> unit val phrase : formatter -> Cmm.phrase -> unit +val raise_kind: formatter -> Cmm.raise_kind -> unit diff --git a/asmcomp/printlinear.ml b/asmcomp/printlinear.ml index fb3d397b..faf26d2d 100644 --- a/asmcomp/printlinear.ml +++ b/asmcomp/printlinear.ml @@ -28,7 +28,7 @@ let instr ppf i = | Lend -> () | Lop op -> begin match op with - | Ialloc _ | Icall_ind | Icall_imm _ | Iextcall(_, _) -> + | Ialloc _ | Icall_ind _ | Icall_imm _ | Iextcall _ -> fprintf ppf "@[<1>{%a}@]@," regsetaddr i.live | _ -> () end; @@ -64,7 +64,7 @@ let instr ppf i = | Lpoptrap -> fprintf ppf "pop trap" | Lraise k -> - fprintf ppf "%s %a" (Lambda.raise_kind k) reg i.arg.(0) + fprintf ppf "%a %a" Printcmm.raise_kind k reg i.arg.(0) end; if not (Debuginfo.is_none i.dbg) then fprintf ppf " %s" (Debuginfo.to_string i.dbg) diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml index 82b95a8b..e9e4937d 100644 --- a/asmcomp/printmach.ml +++ b/asmcomp/printmach.ml @@ -87,7 +87,16 @@ let intop = function | Ilsr -> " >>u " | Iasr -> " >>s " | Icomp cmp -> intcomp cmp - | Icheckbound -> " check > " + | Icheckbound { label_after_error; spacetime_index; } -> + if not Config.spacetime then " check > " + else + Printf.sprintf "check[lbl=%s,index=%d] > " + begin + match label_after_error with + | None -> "" + | Some lbl -> string_of_int lbl + end + spacetime_index let test tst ppf arg = match tst with @@ -110,16 +119,15 @@ let operation op arg ppf res = | Imove -> regs ppf arg | Ispill -> fprintf ppf "%a (spill)" regs arg | Ireload -> fprintf ppf "%a (reload)" regs arg - | Iconst_int n - | Iconst_blockheader n -> fprintf ppf "%s" (Nativeint.to_string n) + | Iconst_int n -> fprintf ppf "%s" (Nativeint.to_string n) | Iconst_float f -> fprintf ppf "%F" (Int64.float_of_bits f) | Iconst_symbol s -> fprintf ppf "\"%s\"" s - | Icall_ind -> fprintf ppf "call %a" regs arg - | Icall_imm lbl -> fprintf ppf "call \"%s\" %a" lbl regs arg - | Itailcall_ind -> fprintf ppf "tailcall %a" regs arg - | Itailcall_imm lbl -> fprintf ppf "tailcall \"%s\" %a" lbl regs arg - | Iextcall(lbl, alloc) -> - fprintf ppf "extcall \"%s\" %a%s" lbl regs arg + | Icall_ind _ -> fprintf ppf "call %a" regs arg + | Icall_imm { func; _ } -> fprintf ppf "call \"%s\" %a" func regs arg + | Itailcall_ind _ -> fprintf ppf "tailcall %a" regs arg + | Itailcall_imm { func; } -> fprintf ppf "tailcall \"%s\" %a" func regs arg + | Iextcall { func; alloc; _ } -> + fprintf ppf "extcall \"%s\" %a%s" func regs arg (if alloc then "" else " (noalloc)") | Istackoffset n -> fprintf ppf "offset stack %i" n @@ -133,7 +141,11 @@ let operation op arg ppf res = (Array.sub arg 1 (Array.length arg - 1)) reg arg.(0) (if is_assign then "(assign)" else "(init)") - | Ialloc n -> fprintf ppf "alloc %i" n + | Ialloc { words = n; _ } -> + fprintf ppf "alloc %i" n; + if Config.spacetime then begin + fprintf ppf "(spacetime node = %a)" reg arg.(0) + end | Iintop(op) -> fprintf ppf "%a%s%a" reg arg.(0) (intop op) reg arg.(1) | Iintop_imm(op, n) -> fprintf ppf "%a%s%i" reg arg.(0) (intop op) n | Inegf -> fprintf ppf "-f %a" reg arg.(0) @@ -188,7 +200,7 @@ let rec instr ppf i = fprintf ppf "@[try@,%a@;<0 -2>with@,%a@;<0 -2>endtry@]" instr body instr handler | Iraise k -> - fprintf ppf "%s %a" (Lambda.raise_kind k) reg i.arg.(0) + fprintf ppf "%a %a" Printcmm.raise_kind k reg i.arg.(0) end; if not (Debuginfo.is_none i.dbg) then fprintf ppf "%s" (Debuginfo.to_string i.dbg); diff --git a/asmcomp/proc.mli b/asmcomp/proc.mli index 06009998..23f503fa 100644 --- a/asmcomp/proc.mli +++ b/asmcomp/proc.mli @@ -39,6 +39,7 @@ val loc_parameters: Reg.t array -> Reg.t array val loc_external_arguments: Reg.t array array -> Reg.t array array * int val loc_external_results: Reg.t array -> Reg.t array val loc_exn_bucket: Reg.t +val loc_spacetime_node_hole: Reg.t (* The maximum number of arguments of an OCaml to OCaml function call for which it is guaranteed there will be no arguments passed on the stack. diff --git a/asmcomp/reloadgen.ml b/asmcomp/reloadgen.ml index 09c68b7e..f40cf02d 100644 --- a/asmcomp/reloadgen.ml +++ b/asmcomp/reloadgen.ml @@ -73,7 +73,7 @@ method reload_operation op arg res = | _ -> (self#makeregs arg, self#makeregs res) -method reload_test tst args = +method reload_test _tst args = self#makeregs args method private reload i = @@ -83,13 +83,13 @@ method private reload i = However, something needs to be done for the function pointer in indirect calls. *) Iend | Ireturn | Iop(Itailcall_imm _) | Iraise _ -> i - | Iop(Itailcall_ind) -> + | Iop(Itailcall_ind _) -> let newarg = self#makereg1 i.arg in insert_moves i.arg newarg {i with arg = newarg} | Iop(Icall_imm _ | Iextcall _) -> {i with next = self#reload i.next} - | Iop(Icall_ind) -> + | Iop(Icall_ind _) -> let newarg = self#makereg1 i.arg in insert_moves i.arg newarg {i with arg = newarg; next = self#reload i.next} @@ -127,7 +127,6 @@ method fundecl f = let new_body = self#reload f.fun_body in ({fun_name = f.fun_name; fun_args = f.fun_args; fun_body = new_body; fun_fast = f.fun_fast; - fun_dbg = f.fun_dbg}, + fun_dbg = f.fun_dbg; fun_spacetime_shape = f.fun_spacetime_shape}, redo_regalloc) - end diff --git a/asmcomp/s390x/CSE.ml b/asmcomp/s390x/CSE.ml index e5805f24..360a4f13 100644 --- a/asmcomp/s390x/CSE.ml +++ b/asmcomp/s390x/CSE.ml @@ -21,7 +21,7 @@ open Arch open Mach open CSEgen -class cse = object (self) +class cse = object inherit cse_generic as super @@ -32,7 +32,7 @@ method! class_of_operation op = method! is_cheap_operation op = match op with - | Iconst_int n | Iconst_blockheader n -> + | Iconst_int n -> n >= -0x8000_0000n && n <= 0x7FFF_FFFFn | _ -> false diff --git a/asmcomp/s390x/arch.ml b/asmcomp/s390x/arch.ml index 954beb93..84d52d64 100644 --- a/asmcomp/s390x/arch.ml +++ b/asmcomp/s390x/arch.ml @@ -35,6 +35,8 @@ type specific_operation = Imultaddf (* multiply and add *) | Imultsubf (* multiply and subtract *) +let spacetime_node_hole_pointer_is_live_before _specific_op = false + (* Addressing modes *) type addressing_mode = @@ -65,8 +67,8 @@ let offset_addressing addr delta = | Iindexed2 n -> Iindexed2(n + delta) let num_args_addressing = function - | Iindexed n -> 1 - | Iindexed2 n -> 2 + | Iindexed _ -> 1 + | Iindexed2 _ -> 2 (* Printing operations and addressing modes *) diff --git a/asmcomp/s390x/emit.mlp b/asmcomp/s390x/emit.mlp index 8226464b..5d233a36 100644 --- a/asmcomp/s390x/emit.mlp +++ b/asmcomp/s390x/emit.mlp @@ -1,3 +1,4 @@ +#2 "asmcomp/s390x/emit.mlp" (**************************************************************************) (* *) (* OCaml *) @@ -15,9 +16,6 @@ (* Emission of Linux on Z 64-bit assembly code *) -module StringSet = - Set.Make(struct type t = string let compare (x:t) y = compare x y end) - open Misc open Cmm open Arch @@ -67,9 +65,6 @@ let label_prefix = ".L" let emit_label lbl = emit_string label_prefix; emit_int lbl -let emit_data_label lbl = - emit_string label_prefix; emit_string "d"; emit_int lbl - (* Section switching *) let data_space = " .section \".data\"\n" @@ -86,10 +81,6 @@ let emit_reg r = | _ -> fatal_error "Emit.emit_reg" -let emit_gpr r = emit_string "%r"; emit_int r - -let emit_fpr r = emit_string "%f"; emit_int r - (* Special registers *) let reg_f15 = phys_reg 115 @@ -157,8 +148,12 @@ let emit_set_comp cmp res = (* Record live pointers at call points *) -let record_frame live dbg = - let lbl = new_label() in +let record_frame ?label live raise_ dbg = + let lbl = + match label with + | None -> new_label() + | Some label -> label + in let live_offset = ref [] in Reg.Set.iter (function @@ -174,6 +169,7 @@ let record_frame live dbg = { fd_lbl = lbl; fd_frame_size = frame_size(); fd_live_offset = !live_offset; + fd_raise = raise_; fd_debuginfo = dbg } :: !frame_descriptors; lbl @@ -199,10 +195,10 @@ type bound_error_call = let bound_error_sites = ref ([] : bound_error_call list) let bound_error_call = ref 0 -let bound_error_label dbg = +let bound_error_label ?label dbg = if !Clflags.debug then begin let lbl_bound_error = new_label() in - let lbl_frame = record_frame Reg.Set.empty dbg in + let lbl_frame = record_frame ?label Reg.Set.empty false dbg in bound_error_sites := { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites; lbl_bound_error @@ -292,22 +288,22 @@ let emit_instr i = let src = i.arg.(0) and dst = i.res.(0) in if src.loc <> dst.loc then begin match (src, dst) with - {loc = Reg rs; typ = (Val | Int | Addr)}, {loc = Reg rd} -> + {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Reg _} -> ` lgr {emit_reg dst}, {emit_reg src}\n` - | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} -> + | {loc = Reg _; typ = Float}, {loc = Reg _; typ = Float} -> ` ldr {emit_reg dst}, {emit_reg src}\n` - | {loc = Reg rs; typ = (Val | Int | Addr)}, {loc = Stack sd} -> + | {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Stack _} -> ` stg {emit_reg src}, {emit_stack dst}\n` - | {loc = Reg rs; typ = Float}, {loc = Stack sd} -> + | {loc = Reg _; typ = Float}, {loc = Stack _} -> ` std {emit_reg src}, {emit_stack dst}\n` - | {loc = Stack ss; typ = (Val | Int | Addr)}, {loc = Reg rd} -> + | {loc = Stack _; typ = (Val | Int | Addr)}, {loc = Reg _} -> ` lg {emit_reg dst}, {emit_stack src}\n` - | {loc = Stack ss; typ = Float}, {loc = Reg rd} -> + | {loc = Stack _; typ = Float}, {loc = Reg _} -> ` ldy {emit_reg dst}, {emit_stack src}\n` | (_, _) -> fatal_error "Emit: Imove" end - | Lop(Iconst_int n | Iconst_blockheader n) -> + | Lop(Iconst_int n) -> if n >= -0x8000n && n <= 0x7FFFn then begin ` lghi {emit_reg i.res.(0)}, {emit_nativeint n}\n`; end else if n >= -0x8000_0000n && n <= 0x7FFF_FFFFn then begin @@ -327,26 +323,26 @@ let emit_instr i = ` lgrl {emit_reg i.res.(0)}, {emit_symbol s}@GOTENT\n` else ` larl {emit_reg i.res.(0)}, {emit_symbol s}\n`; - | Lop(Icall_ind) -> + | Lop(Icall_ind { label_after; }) -> ` basr %r14, {emit_reg i.arg.(0)}\n`; - let lbl = record_frame i.live i.dbg in + let lbl = record_frame i.live false i.dbg ~label:label_after in `{emit_label lbl}:\n` - | Lop(Icall_imm s) -> + | Lop(Icall_imm { func; label_after; }) -> if !pic_code then - ` brasl %r14, {emit_symbol s}@PLT\n` + ` brasl %r14, {emit_symbol func}@PLT\n` else - ` brasl %r14, {emit_symbol s}\n`; - let lbl = record_frame i.live i.dbg in + ` brasl %r14, {emit_symbol func}\n`; + let lbl = record_frame i.live false i.dbg ~label:label_after in `{emit_label lbl}:\n`; - | Lop(Itailcall_ind) -> + | Lop(Itailcall_ind { label_after = _; }) -> let n = frame_size() in if !contains_calls then ` lg %r14, {emit_int(n - size_addr)}(%r15)\n`; emit_stack_adjust (-n); ` br {emit_reg i.arg.(0)}\n` - | Lop(Itailcall_imm s) -> - if s = !function_name then + | Lop(Itailcall_imm { func; label_after = _; }) -> + if func = !function_name then ` brcl 15, {emit_label !tailrec_entry_point}\n` else begin let n = frame_size() in @@ -354,27 +350,27 @@ let emit_instr i = ` lg %r14, {emit_int(n - size_addr)}(%r15)\n`; emit_stack_adjust (-n); if !pic_code then - ` brcl 15, {emit_symbol s}@PLT\n` + ` brcl 15, {emit_symbol func}@PLT\n` else - ` brcl 15, {emit_symbol s}\n` + ` brcl 15, {emit_symbol func}\n` end - | Lop(Iextcall(s, alloc)) -> + | Lop(Iextcall { func; alloc; label_after; }) -> if alloc then begin if !pic_code then begin - ` lgrl %r7, {emit_symbol s}@GOTENT\n`; + ` lgrl %r7, {emit_symbol func}@GOTENT\n`; ` brasl %r14, {emit_symbol "caml_c_call"}@PLT\n` end else begin - ` larl %r7, {emit_symbol s}\n`; + ` larl %r7, {emit_symbol func}\n`; ` brasl %r14, {emit_symbol "caml_c_call"}\n` end; - let lbl = record_frame i.live i.dbg in + let lbl = record_frame i.live false i.dbg ~label:label_after in `{emit_label lbl}:\n`; end else begin if !pic_code then - ` brasl %r14, {emit_symbol s}@PLT\n` + ` brasl %r14, {emit_symbol func}@PLT\n` else - ` brasl %r14, {emit_symbol s}\n` + ` brasl %r14, {emit_symbol func}\n` end | Lop(Istackoffset n) -> @@ -411,10 +407,12 @@ let emit_instr i = | Double | Double_u -> "stdy" in emit_load_store storeinstr addr i.arg 1 i.arg.(0) - | Lop(Ialloc n) -> + | Lop(Ialloc { words = n; label_after_call_gc; }) -> let lbl_redo = new_label() in let lbl_call_gc = new_label() in - let lbl_frame = record_frame i.live i.dbg in + let lbl_frame = + record_frame i.live false i.dbg ?label:label_after_call_gc + in call_gc_sites := { gc_lbl = lbl_call_gc; gc_return_lbl = lbl_redo; @@ -467,8 +465,8 @@ let emit_instr i = ` brc {emit_int mask}, {emit_label lbl}\n`; ` lghi {emit_reg i.res.(0)}, 0\n`; `{emit_label lbl}:\n` - | Lop(Iintop Icheckbound) -> - let lbl = bound_error_label i.dbg in + | Lop(Iintop (Icheckbound { label_after_error; })) -> + let lbl = bound_error_label i.dbg ?label:label_after_error in ` clgr {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; ` brcl 12, {emit_label lbl}\n` (* branch if unsigned le *) | Lop(Iintop op) -> @@ -487,8 +485,8 @@ let emit_instr i = ` brc {emit_int mask}, {emit_label lbl}\n`; ` lghi {emit_reg i.res.(0)}, 0\n`; `{emit_label lbl}:\n` - | Lop(Iintop_imm(Icheckbound, n)) -> - let lbl = bound_error_label i.dbg in + | Lop(Iintop_imm(Icheckbound { label_after_error; }, n)) -> + let lbl = bound_error_label i.dbg ?label:label_after_error in if n >= 0 then begin ` clgfi {emit_reg i.arg.(0)}, {emit_int n}\n`; ` brcl 12, {emit_label lbl}\n` (* branch if unsigned le *) @@ -503,7 +501,7 @@ let emit_instr i = ` srag {emit_reg i.res.(0)}, {emit_reg i.arg.(0)},{emit_int n}(%r0)\n` | Lop(Iintop_imm(Iand, n)) -> assert (i.arg.(0).loc = i.res.(0).loc); - ` nilf {emit_reg i.res.(0)}, {emit_int (n land 0xFFFF_FFFF)}\n` + ` nilf {emit_reg i.res.(0)}, {emit_int (n land (1 lsl 32 - 1)(*0xFFFF_FFFF*))}\n` | Lop(Iintop_imm(Ior, n)) -> assert (i.arg.(0).loc = i.res.(0).loc); ` oilf {emit_reg i.res.(0)}, {emit_int n}\n` @@ -611,17 +609,12 @@ let emit_instr i = emit_stack_adjust (-16); stack_offset := !stack_offset - 16 | Lraise k -> - begin match !Clflags.debug, k with - | true, Lambda.Raise_regular -> + begin match k with + | Cmm.Raise_withtrace -> ` brasl %r14, {emit_symbol "caml_raise_exn"}\n`; - let lbl = record_frame Reg.Set.empty i.dbg in - `{emit_label lbl}:\n` - | true, Lambda.Raise_reraise -> - ` brasl %r14, {emit_symbol "caml_reraise_exn"}\n`; - let lbl = record_frame Reg.Set.empty i.dbg in + let lbl = record_frame Reg.Set.empty true i.dbg in `{emit_label lbl}:\n` - | false, _ - | true, Lambda.Raise_notrace -> + | Cmm.Raise_notrace -> ` lg %r1, 0(%r13)\n`; ` lgr %r15, %r13\n`; ` lg %r13, {emit_int size_addr}(%r15)\n`; @@ -692,8 +685,6 @@ let emit_item = function declare_global_data s | Cdefine_symbol s -> `{emit_symbol s}:\n`; - | Cdefine_label lbl -> - `{emit_data_label lbl}:\n` | Cint8 n -> ` .byte {emit_int n}\n` | Cint16 n -> @@ -708,8 +699,6 @@ let emit_item = function emit_float64_directive ".quad" (Int64.bits_of_float f) | Csymbol_address s -> ` .quad {emit_symbol s}\n` - | Clabel_address lbl -> - ` .quad {emit_data_label lbl}\n` | Cstring s -> emit_bytes_directive " .byte " s | Cskip n -> @@ -759,7 +748,8 @@ let end_assembly() = declare_global_data lbl; `{emit_symbol lbl}:\n`; emit_frames - { efa_label = (fun l -> ` .quad {emit_label l}\n`); + { efa_code_label = (fun l -> ` .quad {emit_label l}\n`); + efa_data_label = (fun l -> ` .quad {emit_label l}\n`); efa_16 = (fun n -> ` .short {emit_int n}\n`); efa_32 = (fun n -> ` .long {emit_int32 n}\n`); efa_word = (fun n -> ` .quad {emit_int n}\n`); diff --git a/asmcomp/s390x/proc.ml b/asmcomp/s390x/proc.ml index dd162966..a8bd2cbf 100644 --- a/asmcomp/s390x/proc.ml +++ b/asmcomp/s390x/proc.ml @@ -94,6 +94,8 @@ let phys_reg n = let stack_slot slot ty = Reg.at_location ty (Stack slot) +let loc_spacetime_node_hole = Reg.dummy (* Spacetime unsupported *) + (* Calling conventions *) let calling_conventions @@ -126,16 +128,16 @@ let calling_conventions let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs -let not_supported ofs = fatal_error "Proc.loc_results: cannot call" +let not_supported _ofs = fatal_error "Proc.loc_results: cannot call" let max_arguments_for_tailcalls = 5 let loc_arguments arg = calling_conventions 0 4 100 103 outgoing 0 arg let loc_parameters arg = - let (loc, ofs) = calling_conventions 0 4 100 103 incoming 0 arg in loc + let (loc, _ofs) = calling_conventions 0 4 100 103 incoming 0 arg in loc let loc_results res = - let (loc, ofs) = calling_conventions 0 4 100 103 not_supported 0 res in loc + let (loc, _ofs) = calling_conventions 0 4 100 103 not_supported 0 res in loc (* C calling conventions under SVR4: use GPR 2-6 and FPR 0,2,4,6 just like ML calling conventions. @@ -150,12 +152,10 @@ let loc_external_arguments arg = calling_conventions 0 4 100 103 outgoing 160 arg in (Array.map (fun reg -> [|reg|]) loc, ofs) -let extcall_use_push = false - (* Results are in GPR 2 and FPR 0 *) let loc_external_results res = - let (loc, ofs) = calling_conventions 0 0 100 100 not_supported 0 res in loc + let (loc, _ofs) = calling_conventions 0 0 100 100 not_supported 0 res in loc (* Exceptions are in GPR 2 *) @@ -163,7 +163,7 @@ let loc_exn_bucket = phys_reg 0 (* Volatile registers: none *) -let regs_are_volatile rs = false +let regs_are_volatile _rs = false (* Registers destroyed by operations *) @@ -173,8 +173,9 @@ let destroyed_at_c_call = 100; 101; 102; 103; 104; 105; 106; 107]) let destroyed_at_oper = function - Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs - | Iop(Iextcall(_, false)) -> destroyed_at_c_call + Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; _ }) -> + all_phys_regs + | Iop(Iextcall { alloc = false; _ }) -> destroyed_at_c_call | _ -> [||] let destroyed_at_raise = all_phys_regs @@ -182,20 +183,20 @@ let destroyed_at_raise = all_phys_regs (* Maximal register pressure *) let safe_register_pressure = function - Iextcall(_, _) -> 4 + Iextcall _ -> 4 | _ -> 9 let max_register_pressure = function - Iextcall(_, _) -> [| 4; 7 |] + Iextcall _ -> [| 4; 7 |] | _ -> [| 9; 15 |] (* Pure operations (without any side effect besides updating their result registers). *) let op_is_pure = function - | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _ | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ - | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> false + | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _) -> false | Ispecific(Imultaddf | Imultsubf) -> true | _ -> true diff --git a/asmcomp/s390x/scheduling.ml b/asmcomp/s390x/scheduling.ml index 6ac11d35..a766d6a3 100644 --- a/asmcomp/s390x/scheduling.ml +++ b/asmcomp/s390x/scheduling.ml @@ -44,7 +44,7 @@ method oper_latency = function | Ispecific(Imultaddf | Imultsubf) -> 8 | _ -> 2 -method reload_retaddr_latency = 4 +method! reload_retaddr_latency = 4 (* Issue cycles. Rough approximations. *) @@ -56,7 +56,7 @@ method oper_issue_cycles = function | Iintop_imm(Icomp _, _) -> 4 | _ -> 1 -method reload_retaddr_issue_cycles = 1 +method! reload_retaddr_issue_cycles = 1 end diff --git a/asmcomp/s390x/selection.ml b/asmcomp/s390x/selection.ml index 4c0df5f0..9a00108d 100644 --- a/asmcomp/s390x/selection.ml +++ b/asmcomp/s390x/selection.ml @@ -51,7 +51,7 @@ let pseudoregs_for_operation op arg res = (* Two-address binary operations: arg.(0) and res.(0) must be the same *) | Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor) | Iaddf|Isubf|Imulf|Idivf -> ([|res.(0); arg.(1)|], res) - | Ispecific(sop) -> + | Ispecific _ -> ( [| arg.(0); arg.(1); res.(0) |], [| res.(0) |]) (* One-address unary operations: arg.(0) and res.(0) must be the same *) | Iintop_imm((Imul|Iand|Ior|Ixor), _) -> (res, res) @@ -62,9 +62,11 @@ class selector = object (self) inherit Selectgen.selector_generic as super -method is_immediate n = (n <= 2147483647) && (n >= -2147483648) +method is_immediate n = n <= 0x7FFF_FFFF && n >= (-1-0x7FFF_FFFF) + (* -1-.... : hack so that this can be compiled on 32-bit + (cf 'make check_all_arches') *) -method select_addressing chunk exp = +method select_addressing _chunk exp = let (a, d) = select_addr exp in (* 20-bit signed displacement *) if d < 0x80000 && d >= -0x80000 then begin @@ -80,9 +82,10 @@ method! select_operation op args = (Cmulhi, _) -> (Iintop Imulh, args) (* The and, or and xor instructions have a different range of immediate operands than the other instructions *) - | (Cand, _) -> self#select_logical Iand (-0x1_0000_0000) (-1) args - | (Cor, _) -> self#select_logical Ior 0 0xFFFF_FFFF args - | (Cxor, _) -> self#select_logical Ixor 0 0xFFFF_FFFF args + | (Cand, _) -> + self#select_logical Iand (-1 lsl 32 (*0x1_0000_0000*)) (-1) args + | (Cor, _) -> self#select_logical Ior 0 (1 lsl 32 - 1 (*0xFFFF_FFFF*)) args + | (Cxor, _) -> self#select_logical Ixor 0 (1 lsl 32 - 1 (*0xFFFF_FFFF*)) args (* Recognize mult-add and mult-sub instructions *) | (Caddf, [Cop(Cmulf, [arg1; arg2]); arg3]) -> (Ispecific Imultaddf, [arg1; arg2; arg3]) diff --git a/asmcomp/schedgen.ml b/asmcomp/schedgen.ml index e228d1c3..440fe2f0 100644 --- a/asmcomp/schedgen.ml +++ b/asmcomp/schedgen.ml @@ -148,9 +148,9 @@ val mutable trywith_nesting = 0 that terminate a basic block. *) method oper_in_basic_block = function - Icall_ind -> false + Icall_ind _ -> false | Icall_imm _ -> false - | Itailcall_ind -> false + | Itailcall_ind _ -> false | Itailcall_imm _ -> false | Iextcall _ -> false | Istackoffset _ -> false @@ -185,8 +185,8 @@ method is_load = function | _ -> false method is_checkbound = function - Iintop Icheckbound -> true - | Iintop_imm(Icheckbound, _) -> true + Iintop (Icheckbound _) -> true + | Iintop_imm(Icheckbound _, _) -> true | _ -> false method private instr_is_store instr = @@ -375,7 +375,7 @@ method schedule_fundecl f = else begin let critical_outputs = match i.desc with - Lop(Icall_ind | Itailcall_ind) -> [| i.arg.(0) |] + Lop(Icall_ind _ | Itailcall_ind _) -> [| i.arg.(0) |] | Lop(Icall_imm _ | Itailcall_imm _ | Iextcall _) -> [||] | Lreturn -> [||] | _ -> i.arg in @@ -389,7 +389,9 @@ method schedule_fundecl f = { fun_name = f.fun_name; fun_body = new_body; fun_fast = f.fun_fast; - fun_dbg = f.fun_dbg } + fun_dbg = f.fun_dbg; + fun_spacetime_shape = f.fun_spacetime_shape; + } end else f diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml index 257327a7..f7e1c0d8 100644 --- a/asmcomp/selectgen.ml +++ b/asmcomp/selectgen.ml @@ -27,15 +27,15 @@ type environment = (Ident.t, Reg.t array) Tbl.t let oper_result_type = function Capply(ty, _) -> ty - | Cextcall(s, ty, alloc, _) -> ty + | Cextcall(_s, ty, _alloc, _, _) -> ty | Cload c -> begin match c with | Word_val -> typ_val | Single | Double | Double_u -> typ_float | _ -> typ_int end - | Calloc -> typ_val - | Cstore (c, _) -> typ_void + | Calloc _ -> typ_val + | Cstore (_c, _) -> typ_void | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi | Cand | Cor | Cxor | Clsl | Clsr | Casr | Ccmpi _ | Ccmpa _ | Ccmpf _ -> typ_int @@ -51,11 +51,11 @@ let oper_result_type = function let size_expr env exp = let rec size localenv = function - Cconst_int _ | Cconst_natint _ - | Cconst_blockheader _ -> Arch.size_int + Cconst_int _ | Cconst_natint _ -> Arch.size_int | Cconst_symbol _ | Cconst_pointer _ | Cconst_natpointer _ -> Arch.size_addr | Cconst_float _ -> Arch.size_float + | Cblockheader _ -> Arch.size_int | Cvar id -> begin try Tbl.find id localenv @@ -69,11 +69,11 @@ let size_expr env exp = end | Ctuple el -> List.fold_right (fun e sz -> size localenv e + sz) el 0 - | Cop(op, args) -> + | Cop(op, _) -> size_machtype(oper_result_type op) | Clet(id, arg, body) -> size (Tbl.add id (size localenv arg) localenv) body - | Csequence(e1, e2) -> + | Csequence(_e1, e2) -> size localenv e2 | _ -> fatal_error "Selection.size_expr" @@ -141,16 +141,25 @@ let join opt_r1 seq1 opt_r2 seq2 = let join_array rs = let some_res = ref None in for i = 0 to Array.length rs - 1 do - let (r, s) = rs.(i) in - if r <> None then some_res := r + let (r, _) = rs.(i) in + match r with + | None -> () + | Some r -> + match !some_res with + | None -> some_res := Some (r, Array.map (fun r -> r.typ) r) + | Some (r', types) -> + let types = + Array.map2 (fun r typ -> Cmm.lub_component r.typ typ) r types + in + some_res := Some (r', types) done; match !some_res with None -> None - | Some template -> + | Some (template, types) -> let size_res = Array.length template in let res = Array.make size_res Reg.dummy in for i = 0 to size_res - 1 do - res.(i) <- Reg.create template.(i).typ + res.(i) <- Reg.create types.(i) done; for i = 0 to Array.length rs - 1 do let (r, s) = rs.(i) in @@ -163,9 +172,10 @@ let join_array rs = (* Extract debug info contained in a C-- operation *) let debuginfo_op = function | Capply(_, dbg) -> dbg - | Cextcall(_, _, _, dbg) -> dbg + | Cextcall(_, _, _, dbg, _) -> dbg | Craise (_, dbg) -> dbg | Ccheckbound dbg -> dbg + | Calloc dbg -> dbg | _ -> Debuginfo.none (* Registers for catch constructs *) @@ -188,19 +198,19 @@ class virtual selector_generic = object (self) method is_simple_expr = function Cconst_int _ -> true | Cconst_natint _ -> true - | Cconst_blockheader _ -> true | Cconst_float _ -> true | Cconst_symbol _ -> true | Cconst_pointer _ -> true | Cconst_natpointer _ -> true + | Cblockheader _ -> true | Cvar _ -> true | Ctuple el -> List.for_all self#is_simple_expr el - | Clet(id, arg, body) -> self#is_simple_expr arg && self#is_simple_expr body + | Clet(_id, arg, body) -> self#is_simple_expr arg && self#is_simple_expr body | Csequence(e1, e2) -> self#is_simple_expr e1 && self#is_simple_expr e2 | Cop(op, args) -> begin match op with (* The following may have side effects *) - | Capply _ | Cextcall _ | Calloc | Cstore _ | Craise _ -> false + | Capply _ | Cextcall _ | Calloc _ | Cstore _ | Craise _ -> false (* The remaining operations are simple if their args are *) | _ -> List.for_all self#is_simple_expr args @@ -231,21 +241,21 @@ method mark_tailcall = () method mark_c_tailcall = () method mark_instr = function - | Iop (Icall_ind | Icall_imm _ | Iextcall _) -> + | Iop (Icall_ind _ | Icall_imm _ | Iextcall _) -> self#mark_call - | Iop (Itailcall_ind | Itailcall_imm _) -> + | Iop (Itailcall_ind _ | Itailcall_imm _) -> self#mark_tailcall | Iop (Ialloc _) -> self#mark_call (* caml_alloc*, caml_garbage_collection *) - | Iop (Iintop Icheckbound | Iintop_imm(Icheckbound, _)) -> + | Iop (Iintop (Icheckbound _) | Iintop_imm(Icheckbound _, _)) -> self#mark_c_tailcall (* caml_ml_array_bound_error *) | Iraise raise_kind -> begin match raise_kind with - | Lambda.Raise_notrace -> () - | Lambda.Raise_regular | Lambda.Raise_reraise -> - if !Clflags.debug then (* PR#6239 *) - (* caml_stash_backtrace; we #mark_call rather than - #mark_c_tailcall to get a good stack backtrace *) + | Cmm.Raise_notrace -> () + | Cmm.Raise_withtrace -> + (* PR#6239 *) + (* caml_stash_backtrace; we #mark_call rather than + #mark_c_tailcall to get a good stack backtrace *) self#mark_call end | Itrywith _ -> @@ -254,11 +264,29 @@ method mark_instr = function (* Default instruction selection for operators *) +method select_allocation words = + Ialloc { words; spacetime_index = 0; label_after_call_gc = None; } +method select_allocation_args _env = [| |] + +method select_checkbound () = + Icheckbound { spacetime_index = 0; label_after_error = None; } +method select_checkbound_extra_args () = [] + method select_operation op args = match (op, args) with - (Capply(ty, dbg), Cconst_symbol s :: rem) -> (Icall_imm s, rem) - | (Capply(ty, dbg), _) -> (Icall_ind, args) - | (Cextcall(s, ty, alloc, dbg), _) -> (Iextcall(s, alloc), args) + | (Capply _, Cconst_symbol func :: rem) -> + let label_after = Cmm.new_label () in + (Icall_imm { func; label_after; }, rem) + | (Capply _, _) -> + let label_after = Cmm.new_label () in + (Icall_ind { label_after; }, args) + | (Cextcall(func, _ty, alloc, _dbg, label_after), _) -> + let label_after = + match label_after with + | None -> Cmm.new_label () + | Some label_after -> label_after + in + Iextcall { func; alloc; label_after; }, args | (Cload chunk, [arg]) -> let (addr, eloc) = self#select_addressing chunk arg in (Iload(chunk, addr), [eloc]) @@ -276,7 +304,7 @@ method select_operation op args = (Istore(chunk, addr, is_assign), [arg2; eloc]) (* Inversion addr/datum in Istore *) end - | (Calloc, _) -> (Ialloc 0, args) + | (Calloc _dbg, _) -> (self#select_allocation 0), args | (Caddi, _) -> self#select_arith_comm Iadd args | (Csubi, _) -> self#select_arith Isub args | (Cmuli, _) -> self#select_arith_comm Imul args @@ -301,7 +329,10 @@ method select_operation op args = | (Cdivf, _) -> (Idivf, args) | (Cfloatofint, _) -> (Ifloatofint, args) | (Cintoffloat, _) -> (Iintoffloat, args) - | (Ccheckbound _, _) -> self#select_arith Icheckbound args + | (Ccheckbound _, _) -> + let extra_args = self#select_checkbound_extra_args () in + let op = self#select_checkbound () in + self#select_arith op (args @ extra_args) | _ -> fatal_error "Selection.select_oper" method private select_arith_comm op = function @@ -389,12 +420,15 @@ method insert_debug desc dbg arg res = method insert desc arg res = instr_seq <- instr_cons desc arg res instr_seq -method extract = +method extract_core ~end_instr = let rec extract res i = if i == dummy_instr then res else extract {i with next = res} i.next in - extract (end_instr()) instr_seq + extract end_instr instr_seq + +method extract = + self#extract_core ~end_instr:(end_instr ()) (* Insert a sequence of moves from one pseudoreg set to another. *) @@ -446,6 +480,20 @@ method insert_op_debug op dbg rs rd = method insert_op op rs rd = self#insert_op_debug op Debuginfo.none rs rd +method emit_blockheader _env n _dbg = + let r = self#regs_for typ_int in + Some(self#insert_op (Iconst_int n) [||] r) + +method about_to_emit_call _env _insn _arg = None + +(* Prior to a function call, update the Spacetime node hole pointer hard + register. *) + +method private maybe_emit_spacetime_move ~spacetime_reg = + Misc.Stdlib.Option.iter (fun reg -> + self#insert_moves reg [| Proc.loc_spacetime_node_hole |]) + spacetime_reg + (* Add the instructions for the given expression at the end of the self sequence *) @@ -457,9 +505,6 @@ method emit_expr env exp = | Cconst_natint n -> let r = self#regs_for typ_int in Some(self#insert_op (Iconst_int n) [||] r) - | Cconst_blockheader n -> - let r = self#regs_for typ_int in - Some(self#insert_op (Iconst_blockheader n) [||] r) | Cconst_float n -> let r = self#regs_for typ_float in Some(self#insert_op (Iconst_float (Int64.bits_of_float n)) [||] r) @@ -472,6 +517,8 @@ method emit_expr env exp = | Cconst_natpointer n -> let r = self#regs_for typ_val in (* integer as Caml value *) Some(self#insert_op (Iconst_int n) [||] r) + | Cblockheader(n, dbg) -> + self#emit_blockheader env n dbg | Cvar v -> begin try Some(Tbl.find v env) @@ -510,7 +557,7 @@ method emit_expr env exp = self#insert_debug (Iraise k) dbg rd [||]; None end - | Cop(Ccmpf comp, args) -> + | Cop(Ccmpf _, _) -> self#emit_expr env (Cifthenelse(exp, Cconst_int 1, Cconst_int 0)) | Cop(op, args) -> begin match self#emit_parts_list env args with @@ -520,37 +567,54 @@ method emit_expr env exp = let (new_op, new_args) = self#select_operation op simple_args in let dbg = debuginfo_op op in match new_op with - Icall_ind -> + Icall_ind _ -> let r1 = self#emit_tuple env new_args in let rarg = Array.sub r1 1 (Array.length r1 - 1) in let rd = self#regs_for ty in let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in let loc_res = Proc.loc_results rd in + let spacetime_reg = + self#about_to_emit_call env (Iop new_op) [| r1.(0) |] + in self#insert_move_args rarg loc_arg stack_ofs; - self#insert_debug (Iop Icall_ind) dbg + self#maybe_emit_spacetime_move ~spacetime_reg; + self#insert_debug (Iop new_op) dbg (Array.append [|r1.(0)|] loc_arg) loc_res; self#insert_move_results loc_res rd stack_ofs; Some rd - | Icall_imm lbl -> + | Icall_imm _ -> let r1 = self#emit_tuple env new_args in let rd = self#regs_for ty in let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in let loc_res = Proc.loc_results rd in + let spacetime_reg = + self#about_to_emit_call env (Iop new_op) [| |] + in self#insert_move_args r1 loc_arg stack_ofs; - self#insert_debug (Iop(Icall_imm lbl)) dbg loc_arg loc_res; + self#maybe_emit_spacetime_move ~spacetime_reg; + self#insert_debug (Iop new_op) dbg loc_arg loc_res; self#insert_move_results loc_res rd stack_ofs; Some rd - | Iextcall(lbl, alloc) -> + | Iextcall _ -> + let spacetime_reg = + self#about_to_emit_call env (Iop new_op) [| |] + in let (loc_arg, stack_ofs) = self#emit_extcall_args env new_args in + self#maybe_emit_spacetime_move ~spacetime_reg; let rd = self#regs_for ty in - let loc_res = self#insert_op_debug (Iextcall(lbl, alloc)) dbg - loc_arg (Proc.loc_external_results rd) in + let loc_res = + self#insert_op_debug new_op dbg + loc_arg (Proc.loc_external_results rd) in self#insert_move_results loc_res rd stack_ofs; Some rd - | Ialloc _ -> + | Ialloc { words = _; spacetime_index; label_after_call_gc; } -> let rd = self#regs_for typ_val in let size = size_expr env (Ctuple new_args) in - self#insert (Iop(Ialloc size)) [||] rd; + let op = + Ialloc { words = size; spacetime_index; label_after_call_gc; } + in + let args = self#select_allocation_args env in + self#insert_debug (Iop op) dbg args rd; self#emit_stores env new_args rd; Some rd | op -> @@ -561,7 +625,7 @@ method emit_expr env exp = | Csequence(e1, e2) -> begin match self#emit_expr env e1 with None -> None - | Some r1 -> self#emit_expr env e2 + | Some _ -> self#emit_expr env e2 end | Cifthenelse(econd, eif, eelse) -> let (cond, earg) = self#select_condition econd in @@ -582,12 +646,12 @@ method emit_expr env exp = let rscases = Array.map (self#emit_sequence env) ecases in let r = join_array rscases in self#insert (Iswitch(index, - Array.map (fun (r, s) -> s#extract) rscases)) + Array.map (fun (_, s) -> s#extract) rscases)) rsel [||]; r end | Cloop(ebody) -> - let (rarg, sbody) = self#emit_sequence env ebody in + let (_rarg, sbody) = self#emit_sequence env ebody in self#insert (Iloop(sbody#extract)) [||] [||]; Some [||] | Ccatch(nfail, ids, e1, e2) -> @@ -761,38 +825,61 @@ method emit_tail env exp = | Some(simple_args, env) -> let (new_op, new_args) = self#select_operation op simple_args in match new_op with - Icall_ind -> + Icall_ind { label_after; } -> let r1 = self#emit_tuple env new_args in let rarg = Array.sub r1 1 (Array.length r1 - 1) in let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in if stack_ofs = 0 then begin + let call = Iop (Itailcall_ind { label_after; }) in + let spacetime_reg = + self#about_to_emit_call env call [| r1.(0) |] + in self#insert_moves rarg loc_arg; - self#insert (Iop Itailcall_ind) - (Array.append [|r1.(0)|] loc_arg) [||] + self#maybe_emit_spacetime_move ~spacetime_reg; + self#insert_debug call dbg + (Array.append [|r1.(0)|] loc_arg) [||]; end else begin let rd = self#regs_for ty in let loc_res = Proc.loc_results rd in + let spacetime_reg = + self#about_to_emit_call env (Iop new_op) [| r1.(0) |] + in self#insert_move_args rarg loc_arg stack_ofs; - self#insert_debug (Iop Icall_ind) dbg + self#maybe_emit_spacetime_move ~spacetime_reg; + self#insert_debug (Iop new_op) dbg (Array.append [|r1.(0)|] loc_arg) loc_res; self#insert(Iop(Istackoffset(-stack_ofs))) [||] [||]; self#insert Ireturn loc_res [||] end - | Icall_imm lbl -> + | Icall_imm { func; label_after; } -> let r1 = self#emit_tuple env new_args in let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in if stack_ofs = 0 then begin + let call = Iop (Itailcall_imm { func; label_after; }) in + let spacetime_reg = + self#about_to_emit_call env call [| |] + in self#insert_moves r1 loc_arg; - self#insert (Iop(Itailcall_imm lbl)) loc_arg [||] - end else if lbl = !current_function_name then begin + self#maybe_emit_spacetime_move ~spacetime_reg; + self#insert_debug call dbg loc_arg [||]; + end else if func = !current_function_name then begin + let call = Iop (Itailcall_imm { func; label_after; }) in let loc_arg' = Proc.loc_parameters r1 in + let spacetime_reg = + self#about_to_emit_call env call [| |] + in self#insert_moves r1 loc_arg'; - self#insert (Iop(Itailcall_imm lbl)) loc_arg' [||] + self#maybe_emit_spacetime_move ~spacetime_reg; + self#insert_debug call dbg loc_arg' [||]; end else begin let rd = self#regs_for ty in let loc_res = Proc.loc_results rd in + let spacetime_reg = + self#about_to_emit_call env (Iop new_op) [| |] + in self#insert_move_args r1 loc_arg stack_ofs; - self#insert_debug (Iop(Icall_imm lbl)) dbg loc_arg loc_res; + self#maybe_emit_spacetime_move ~spacetime_reg; + self#insert_debug (Iop new_op) dbg loc_arg loc_res; self#insert(Iop(Istackoffset(-stack_ofs))) [||] [||]; self#insert Ireturn loc_res [||] end @@ -801,7 +888,7 @@ method emit_tail env exp = | Csequence(e1, e2) -> begin match self#emit_expr env e1 with None -> () - | Some r1 -> self#emit_tail env e2 + | Some _ -> self#emit_tail env e2 end | Cifthenelse(econd, eif, eelse) -> let (cond, earg) = self#select_condition econd in @@ -860,8 +947,16 @@ method private emit_tail_sequence env exp = s#emit_tail env exp; s#extract +(* Insertion of the function prologue *) + +method insert_prologue _f ~loc_arg ~rarg ~spacetime_node_hole:_ ~env:_ = + self#insert_moves loc_arg rarg; + None + (* Sequentialization of a function definition *) +method initial_env () = Tbl.empty + method emit_fundecl f = Proc.contains_calls := false; current_function_name := f.Cmm.fun_name; @@ -871,19 +966,38 @@ method emit_fundecl f = f.Cmm.fun_args in let rarg = Array.concat rargs in let loc_arg = Proc.loc_parameters rarg in + (* To make it easier to add the Spacetime instrumentation code, we + first emit the body and extract the resulting instruction sequence; + then we emit the prologue followed by any Spacetime instrumentation. The + sequence resulting from extracting the latter (prologue + instrumentation) + together is then simply prepended to the body. *) let env = List.fold_right2 - (fun (id, ty) r env -> Tbl.add id r env) - f.Cmm.fun_args rargs Tbl.empty in - self#insert_moves loc_arg rarg; + (fun (id, _ty) r env -> Tbl.add id r env) + f.Cmm.fun_args rargs (self#initial_env ()) in + let spacetime_node_hole, env = + if not Config.spacetime then None, env + else begin + let reg = self#regs_for typ_int in + let node_hole = Ident.create "spacetime_node_hole" in + Some (node_hole, reg), Tbl.add node_hole reg env + end + in self#emit_tail env f.Cmm.fun_body; let body = self#extract in + instr_seq <- dummy_instr; + let fun_spacetime_shape = + self#insert_prologue f ~loc_arg ~rarg ~spacetime_node_hole ~env + in + let body = self#extract_core ~end_instr:body in instr_iter (fun instr -> self#mark_instr instr.Mach.desc) body; { fun_name = f.Cmm.fun_name; fun_args = loc_arg; fun_body = body; fun_fast = f.Cmm.fun_fast; - fun_dbg = f.Cmm.fun_dbg } + fun_dbg = f.Cmm.fun_dbg; + fun_spacetime_shape; + } end @@ -895,7 +1009,7 @@ end let is_tail_call nargs = assert (Reg.dummy.typ = Int); let args = Array.make (nargs + 1) Reg.dummy in - let (loc_arg, stack_ofs) = Proc.loc_arguments args in + let (_loc_arg, stack_ofs) = Proc.loc_arguments args in stack_ofs = 0 let _ = diff --git a/asmcomp/selectgen.mli b/asmcomp/selectgen.mli index b579b07b..5df80ad3 100644 --- a/asmcomp/selectgen.mli +++ b/asmcomp/selectgen.mli @@ -86,13 +86,15 @@ class virtual selector_generic : object above; overloading this is useful if Ispecific instructions need marking *) - (* The following method is the entry point and should not be overridden *) + (* The following method is the entry point and should not be overridden + (except by [Spacetime_profiling]). *) method emit_fundecl : Cmm.fundecl -> Mach.fundecl (* The following methods should not be overridden. They cannot be declared "private" in the current implementation because they are not always applied to "self", but ideally they should be private. *) method extract : Mach.instruction + method extract_core : end_instr:Mach.instruction -> Mach.instruction method insert : Mach.instruction_desc -> Reg.t array -> Reg.t array -> unit method insert_debug : Mach.instruction_desc -> Debuginfo.t -> Reg.t array -> Reg.t array -> unit @@ -105,6 +107,32 @@ class virtual selector_generic : object method emit_expr : (Ident.t, Reg.t array) Tbl.t -> Cmm.expression -> Reg.t array option method emit_tail : (Ident.t, Reg.t array) Tbl.t -> Cmm.expression -> unit + + (* Only for the use of [Spacetime_profiling]. *) + method select_allocation : int -> Mach.operation + method select_allocation_args : (Ident.t, Reg.t array) Tbl.t -> Reg.t array + method select_checkbound : unit -> Mach.integer_operation + method select_checkbound_extra_args : unit -> Cmm.expression list + method emit_blockheader + : (Ident.t, Reg.t array) Tbl.t + -> nativeint + -> Debuginfo.t + -> Reg.t array option + method about_to_emit_call + : (Ident.t, Reg.t array) Tbl.t + -> Mach.instruction_desc + -> Reg.t array + -> Reg.t array option + method initial_env : unit -> (Ident.t, Reg.t array) Tbl.t + method insert_prologue + : Cmm.fundecl + -> loc_arg:Reg.t array + -> rarg:Reg.t array + -> spacetime_node_hole:(Ident.t * Reg.t array) option + -> env:(Ident.t, Reg.t array) Tbl.t + -> Mach.spacetime_shape option + + val mutable instr_seq : Mach.instruction end val reset : unit -> unit diff --git a/asmcomp/spacetime_profiling.ml b/asmcomp/spacetime_profiling.ml new file mode 100644 index 00000000..32037c55 --- /dev/null +++ b/asmcomp/spacetime_profiling.ml @@ -0,0 +1,421 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* 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 node_num_header_words = 2 (* [Node_num_header_words] in the runtime. *) +let index_within_node = ref node_num_header_words +(* The [lazy]s are to ensure that we don't create [Ident.t]s at toplevel + when not using Spacetime profiling. (This could cause stamps to differ + between bytecode and native .cmis when no .mli is present, e.g. + arch.ml.) *) +let spacetime_node = ref (lazy (Cmm.Cvar (Ident.create "dummy"))) +let spacetime_node_ident = ref (lazy (Ident.create "dummy")) +let current_function_label = ref "" +let direct_tail_call_point_indexes = ref [] + +let reverse_shape = ref ([] : Mach.spacetime_shape) + +let something_was_instrumented () = + !index_within_node > node_num_header_words + +let next_index_within_node ~part_of_shape ~label = + let index = !index_within_node in + begin match part_of_shape with + | Mach.Direct_call_point _ | Mach.Indirect_call_point -> + incr index_within_node + | Mach.Allocation_point -> + incr index_within_node; + incr index_within_node; + incr index_within_node + end; + reverse_shape := (part_of_shape, label) :: !reverse_shape; + index + +let reset ~spacetime_node_ident:ident ~function_label = + index_within_node := node_num_header_words; + spacetime_node := lazy (Cmm.Cvar ident); + spacetime_node_ident := lazy ident; + direct_tail_call_point_indexes := []; + current_function_label := function_label; + reverse_shape := [] + +let code_for_function_prologue ~function_name ~node_hole = + let node = Ident.create "node" in + let new_node = Ident.create "new_node" in + let must_allocate_node = Ident.create "must_allocate_node" in + let is_new_node = Ident.create "is_new_node" in + let no_tail_calls = List.length !direct_tail_call_point_indexes < 1 in + let open Cmm in + let initialize_direct_tail_call_points_and_return_node = + let new_node_encoded = Ident.create "new_node_encoded" in + (* The callee node pointers within direct tail call points must initially + point back at the start of the current node and be marked as per + [Encode_tail_caller_node] in the runtime. *) + let indexes = !direct_tail_call_point_indexes in + let body = + List.fold_left (fun init_code index -> + (* Cf. [Direct_callee_node] in the runtime. *) + let offset_in_bytes = index * Arch.size_addr in + Csequence ( + Cop (Cstore (Word_int, Lambda.Assignment), + [Cop (Caddi, [Cvar new_node; Cconst_int offset_in_bytes]); + Cvar new_node_encoded]), + init_code)) + (Cvar new_node) + indexes + in + match indexes with + | [] -> body + | _ -> + Clet (new_node_encoded, + (* Cf. [Encode_tail_caller_node] in the runtime. *) + Cop (Cor, [Cvar new_node; Cconst_int 1]), + body) + in + let pc = Ident.create "pc" in + Clet (node, Cop (Cload Word_int, [Cvar node_hole]), + Clet (must_allocate_node, Cop (Cand, [Cvar node; Cconst_int 1]), + Cifthenelse (Cop (Ccmpi Cne, [Cvar must_allocate_node; Cconst_int 1]), + Cvar node, + Clet (is_new_node, + Clet (pc, Cconst_symbol function_name, + Cop (Cextcall ("caml_spacetime_allocate_node", + [| Int |], false, Debuginfo.none, None), + [Cconst_int (1 (* header *) + !index_within_node); + Cvar pc; + Cvar node_hole; + ])), + Clet (new_node, Cop (Cload Word_int, [Cvar node_hole]), + if no_tail_calls then Cvar new_node + else + Cifthenelse ( + Cop (Ccmpi Ceq, [Cvar is_new_node; Cconst_int 0]), + Cvar new_node, + initialize_direct_tail_call_points_and_return_node)))))) + +let code_for_blockheader ~value's_header ~node ~dbg = + let num_words = Nativeint.shift_right_logical value's_header 10 in + let existing_profinfo = Ident.create "existing_profinfo" in + let existing_count = Ident.create "existing_count" in + let profinfo = Ident.create "profinfo" in + let address_of_profinfo = Ident.create "address_of_profinfo" in + let label = Cmm.new_label () in + let index_within_node = + next_index_within_node ~part_of_shape:Mach.Allocation_point ~label + in + let offset_into_node = Arch.size_addr * index_within_node in + let open Cmm in + let generate_new_profinfo = + (* This will generate a static branch to a function that should usually + be in the cache, which hopefully gives a good code size/performance + balance. + The "Some label" is important: it provides the link between the shape + table, the allocation point, and the frame descriptor table---enabling + the latter table to be used for resolving a program counter at such + a point to a location. + *) + Cop (Cextcall ("caml_spacetime_generate_profinfo", [| Int |], + false, dbg, Some label), + [Cvar address_of_profinfo; + Cconst_int (index_within_node + 1)]) + in + (* Check if we have already allocated a profinfo value for this allocation + point with the current backtrace. If so, use that value; if not, + allocate a new one. *) + Clet (address_of_profinfo, + Cop (Caddi, [ + Cvar node; + Cconst_int offset_into_node; + ]), + Clet (existing_profinfo, Cop (Cload Word_int, [Cvar address_of_profinfo]), + Clet (profinfo, + Cifthenelse ( + Cop (Ccmpi Cne, [Cvar existing_profinfo; Cconst_int 1 (* () *)]), + Cvar existing_profinfo, + generate_new_profinfo), + Clet (existing_count, + Cop (Cload Word_int, [ + Cop (Caddi, + [Cvar address_of_profinfo; Cconst_int Arch.size_addr]) + ]), + Csequence ( + Cop (Cstore (Word_int, Lambda.Assignment), + [Cop (Caddi, + [Cvar address_of_profinfo; Cconst_int Arch.size_addr]); + Cop (Caddi, [ + Cvar existing_count; + (* N.B. "*2" since the count is an OCaml integer. + The "1 +" is to count the value's header. *) + Cconst_int (2 * (1 + Nativeint.to_int num_words)); + ]); + ]), + (* [profinfo] looks like a black [Infix_tag] header. Instead of + having to mask [profinfo] before ORing it with the desired + header, we can use an XOR trick, to keep code size down. *) + let value's_header = + Nativeint.logxor value's_header + (Nativeint.logor + ((Nativeint.logor (Nativeint.of_int Obj.infix_tag) + (Nativeint.shift_left 3n (* <- Caml_black *) 8))) + (Nativeint.shift_left + (* The following is the [Infix_offset_val], in words. *) + (Nativeint.of_int (index_within_node + 1)) 10)) + in + Cop (Cxor, [Cvar profinfo; Cconst_natint value's_header])))))) + +type callee = + | Direct of string + | Indirect of Cmm.expression + +let code_for_call ~node ~callee ~is_tail ~label = + (* We treat self recursive calls as tail calls to avoid blow-ups in the + graph. *) + let is_self_recursive_call = + match callee with + | Direct callee -> callee = !current_function_label + | Indirect _ -> false + in + let is_tail = is_tail || is_self_recursive_call in + let index_within_node = + match callee with + | Direct callee -> + next_index_within_node + ~part_of_shape:(Mach.Direct_call_point { callee; }) + ~label + | Indirect _ -> + next_index_within_node ~part_of_shape:Mach.Indirect_call_point ~label + in + begin match callee with + (* If this is a direct tail call point, we need to note down its index, + so the correct initialization code can be emitted in the prologue. *) + | Direct _ when is_tail -> + direct_tail_call_point_indexes := + index_within_node::!direct_tail_call_point_indexes + | Direct _ | Indirect _ -> () + end; + let place_within_node = Ident.create "place_within_node" in + let open Cmm in + Clet (place_within_node, + Cop (Caddi, [node; Cconst_int (index_within_node * Arch.size_addr)]), + (* The following code returns the address that is to be moved into the + (hard) node hole pointer register immediately before the call. + (That move is inserted in [Selectgen].) *) + match callee with + | Direct _callee -> Cvar place_within_node + | Indirect callee -> + let caller_node = + if is_tail then node + else Cconst_int 1 (* [Val_unit] *) + in + Cop (Cextcall ("caml_spacetime_indirect_node_hole_ptr", + [| Int |], false, Debuginfo.none, None), + [callee; Cvar place_within_node; caller_node])) + +class virtual instruction_selection = object (self) + inherit Selectgen.selector_generic as super + + (* [disable_instrumentation] ensures that we don't try to instrument the + instrumentation... *) + val mutable disable_instrumentation = false + + method private instrument_direct_call ~env ~func ~is_tail ~label_after = + let instrumentation = + code_for_call + ~node:(Lazy.force !spacetime_node) + ~callee:(Direct func) + ~is_tail + ~label:label_after + in + match self#emit_expr env instrumentation with + | None -> assert false + | Some reg -> Some reg + + method private instrument_indirect_call ~env ~callee ~is_tail + ~label_after = + (* [callee] is a pseudoregister, so we have to bind it in the environment + and reference the variable to which it is bound. *) + let callee_ident = Ident.create "callee" in + let env = Tbl.add callee_ident [| callee |] env in + let instrumentation = + code_for_call + ~node:(Lazy.force !spacetime_node) + ~callee:(Indirect (Cmm.Cvar callee_ident)) + ~is_tail + ~label:label_after + in + match self#emit_expr env instrumentation with + | None -> assert false + | Some reg -> Some reg + + method private can_instrument () = + Config.spacetime && not disable_instrumentation + + method! about_to_emit_call env desc arg = + if not (self#can_instrument ()) then None + else + let module M = Mach in + match desc with + | M.Iop (M.Icall_imm { func; label_after; }) -> + assert (Array.length arg = 0); + self#instrument_direct_call ~env ~func ~is_tail:false ~label_after + | M.Iop (M.Icall_ind { label_after; }) -> + assert (Array.length arg = 1); + self#instrument_indirect_call ~env ~callee:arg.(0) + ~is_tail:false ~label_after + | M.Iop (M.Itailcall_imm { func; label_after; }) -> + assert (Array.length arg = 0); + self#instrument_direct_call ~env ~func ~is_tail:true ~label_after + | M.Iop (M.Itailcall_ind { label_after; }) -> + assert (Array.length arg = 1); + self#instrument_indirect_call ~env ~callee:arg.(0) + ~is_tail:true ~label_after + | M.Iop (M.Iextcall { func; alloc = true; label_after; }) -> + (* N.B. No need to instrument "noalloc" external calls. *) + assert (Array.length arg = 0); + self#instrument_direct_call ~env ~func ~is_tail:false ~label_after + | _ -> None + + method private instrument_blockheader ~env ~value's_header ~dbg = + let instrumentation = + code_for_blockheader + ~node:(Lazy.force !spacetime_node_ident) + ~value's_header ~dbg + in + self#emit_expr env instrumentation + + method private emit_prologue f ~node_hole ~env = + (* We don't need the prologue unless we inserted some instrumentation. + This corresponds to adding the prologue if the function contains one + or more call or allocation points. *) + if something_was_instrumented () then begin + let prologue_cmm = + code_for_function_prologue ~function_name:f.Cmm.fun_name ~node_hole + in + disable_instrumentation <- true; + let node_temp_reg = + match self#emit_expr env prologue_cmm with + | None -> + Misc.fatal_error "Spacetime prologue instruction \ + selection did not yield a destination register" + | Some node_temp_reg -> node_temp_reg + in + disable_instrumentation <- false; + let node = Lazy.force !spacetime_node_ident in + let node_reg = Tbl.find node env in + self#insert_moves node_temp_reg node_reg + end + + method! emit_blockheader env n dbg = + if self#can_instrument () then begin + disable_instrumentation <- true; + let result = self#instrument_blockheader ~env ~value's_header:n ~dbg in + disable_instrumentation <- false; + result + end else begin + super#emit_blockheader env n dbg + end + + method! select_allocation words = + if self#can_instrument () then begin + (* Leave space for a direct call point. We cannot easily insert any + instrumentation code, so the fields are filled in instead by + [caml_spacetime_caml_garbage_collection]. *) + let label = Cmm.new_label () in + let index = + next_index_within_node + ~part_of_shape:(Mach.Direct_call_point { callee = "caml_call_gc"; }) + ~label + in + Mach.Ialloc { + words; + label_after_call_gc = Some label; + spacetime_index = index; + } + end else begin + super#select_allocation words + end + + method! select_allocation_args env = + if self#can_instrument () then begin + let regs = Tbl.find (Lazy.force !spacetime_node_ident) env in + match regs with + | [| reg |] -> [| reg |] + | _ -> failwith "Expected one register only for spacetime_node_ident" + end else begin + super#select_allocation_args env + end + + method! select_checkbound () = + (* This follows [select_allocation], above. *) + if self#can_instrument () then begin + let label = Cmm.new_label () in + let index = + next_index_within_node + ~part_of_shape:( + Mach.Direct_call_point { callee = "caml_ml_array_bound_error"; }) + ~label + in + Mach.Icheckbound { + label_after_error = Some label; + spacetime_index = index; + } + end else begin + super#select_checkbound () + end + + method! select_checkbound_extra_args () = + if self#can_instrument () then begin + (* This follows [select_allocation_args], above. *) + [Cmm.Cvar (Lazy.force !spacetime_node_ident)] + end else begin + super#select_checkbound_extra_args () + end + + method! initial_env () = + let env = super#initial_env () in + if Config.spacetime then + Tbl.add (Lazy.force !spacetime_node_ident) + (self#regs_for Cmm.typ_int) env + else + env + + method! emit_fundecl f = + if Config.spacetime then begin + disable_instrumentation <- false; + let node = Ident.create "spacetime_node" in + reset ~spacetime_node_ident:node ~function_label:f.Cmm.fun_name + end; + super#emit_fundecl f + + method! insert_prologue f ~loc_arg ~rarg ~spacetime_node_hole ~env = + let fun_spacetime_shape = + super#insert_prologue f ~loc_arg ~rarg ~spacetime_node_hole ~env + in + (* CR-soon mshinwell: add check to make sure the node size doesn't exceed + the chunk size of the allocator *) + if not Config.spacetime then fun_spacetime_shape + else begin + let node_hole, node_hole_reg = + match spacetime_node_hole with + | None -> assert false + | Some (node_hole, reg) -> node_hole, reg + in + self#insert_moves [| Proc.loc_spacetime_node_hole |] node_hole_reg; + self#emit_prologue f ~node_hole ~env; + match !reverse_shape with + | [] -> None + (* N.B. We do not reverse the shape list, since the function that + reconstructs it (caml_spacetime_shape_table) reverses it again. *) + | reverse_shape -> Some reverse_shape + end +end diff --git a/asmcomp/spacetime_profiling.mli b/asmcomp/spacetime_profiling.mli new file mode 100644 index 00000000..16c69148 --- /dev/null +++ b/asmcomp/spacetime_profiling.mli @@ -0,0 +1,17 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(** Insertion of instrumentation code for Spacetime profiling. *) + +class virtual instruction_selection : Selectgen.selector_generic diff --git a/asmcomp/sparc/CSE.ml b/asmcomp/sparc/CSE.ml index 6c4cf458..7d246ba3 100644 --- a/asmcomp/sparc/CSE.ml +++ b/asmcomp/sparc/CSE.ml @@ -18,13 +18,13 @@ open Mach open CSEgen -class cse = object (self) +class cse = object inherit cse_generic (* as super *) method! is_cheap_operation op = match op with - | Iconst_int n | Iconst_blockheader n -> n <= 4095n && n >= -4096n + | Iconst_int n -> n <= 4095n && n >= -4096n | _ -> false end diff --git a/asmcomp/sparc/arch.ml b/asmcomp/sparc/arch.ml index f7e388be..1f7e2abd 100644 --- a/asmcomp/sparc/arch.ml +++ b/asmcomp/sparc/arch.ml @@ -33,6 +33,8 @@ let command_line_options = type specific_operation = unit (* None worth mentioning *) +let spacetime_node_hole_pointer_is_live_before _specific_op = false + (* Addressing modes *) type addressing_mode = @@ -63,8 +65,8 @@ let offset_addressing addr delta = | Iindexed n -> Iindexed(n + delta) let num_args_addressing = function - Ibased(s, n) -> 0 - | Iindexed n -> 1 + Ibased _ -> 0 + | Iindexed _ -> 1 (* Printing operations and addressing modes *) @@ -77,5 +79,5 @@ let print_addressing printreg addr ppf arg = let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in fprintf ppf "%a%s" printreg arg.(0) idx -let print_specific_operation printreg op ppf arg = +let print_specific_operation _printreg _op _ppf _arg = Misc.fatal_error "Arch_sparc.print_specific_operation" diff --git a/asmcomp/sparc/emit.mlp b/asmcomp/sparc/emit.mlp index 74d61be2..78d0098d 100644 --- a/asmcomp/sparc/emit.mlp +++ b/asmcomp/sparc/emit.mlp @@ -1,3 +1,4 @@ +#2 "asmcomp/sparc/emit.mlp" (**************************************************************************) (* *) (* OCaml *) @@ -98,9 +99,6 @@ let label_prefix = let emit_label lbl = emit_string label_prefix; emit_int lbl -let emit_data_label lbl = - emit_string label_prefix; emit_string "d"; emit_int lbl - (* Output a pseudo-register *) let emit_reg r = @@ -163,8 +161,12 @@ type frame_descr = let frame_descriptors = ref([] : frame_descr list) -let record_frame live = - let lbl = new_label() in +let record_frame ?label live = + let lbl = + match label with + | None -> new_label() + | Some label -> label + in let live_offset = ref [] in Reg.Set.iter (function @@ -278,16 +280,16 @@ let rec emit_instr i dslot = | Lop(Imove | Ispill | Ireload) -> let src = i.arg.(0) and dst = i.res.(0) in begin match (src, dst) with - {loc = Reg rs; typ = (Int | Addr | Val)}, {loc = Reg rd} -> + {loc = Reg _; typ = (Int | Addr | Val)}, {loc = Reg _} -> ` mov {emit_reg src}, {emit_reg dst}\n` - | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} -> + | {loc = Reg _; typ = Float}, {loc = Reg _; typ = Float} -> if !arch_version = SPARC_V9 then ` fmovd {emit_reg src}, {emit_reg dst}\n` else begin ` fmovs {emit_reg src}, {emit_reg dst}\n`; ` fmovs {emit_reg(next_in_pair src)}, {emit_reg(next_in_pair dst)}\n` end - | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = (Int | Addr | Val)} -> + | {loc = Reg _; typ = Float}, {loc = Reg _; typ = (Int | Addr | Val)} -> (* This happens when calling C functions and passing a float arg in %o0...%o5 *) ` sub %sp, 8, %sp\n`; @@ -304,18 +306,18 @@ let rec emit_instr i dslot = fatal_error "Emit: Imove Float [| _; _ |]" end; ` add %sp, 8, %sp\n` - | {loc = Reg rs; typ = (Int | Addr | Val)}, {loc = Stack sd} -> + | {loc = Reg _; typ = (Int | Addr | Val)}, {loc = Stack _} -> ` st {emit_reg src}, {emit_stack dst}\n` - | {loc = Reg rs; typ = Float}, {loc = Stack sd} -> + | {loc = Reg _; typ = Float}, {loc = Stack _} -> ` std {emit_reg src}, {emit_stack dst}\n` - | {loc = Stack ss; typ = (Int | Addr | Val)}, {loc = Reg rd} -> + | {loc = Stack _; typ = (Int | Addr | Val)}, {loc = Reg _} -> ` ld {emit_stack src}, {emit_reg dst}\n` - | {loc = Stack ss; typ = Float}, {loc = Reg rd} -> + | {loc = Stack _; typ = Float}, {loc = Reg _} -> ` ldd {emit_stack src}, {emit_reg dst}\n` | (_, _) -> fatal_error "Emit: Imove" end - | Lop(Iconst_int n | Iconst_blockheader n) -> + | Lop(Iconst_int n) -> if is_native_immediate n then ` mov {emit_nativeint n}, {emit_reg i.res.(0)}\n` else begin @@ -332,37 +334,37 @@ let rec emit_instr i dslot = | Lop(Iconst_symbol s) -> ` sethi %hi({emit_symbol s}), %g1\n`; ` or %g1, %lo({emit_symbol s}), {emit_reg i.res.(0)}\n` - | Lop(Icall_ind) -> - `{record_frame i.live} call {emit_reg i.arg.(0)}\n`; + | Lop(Icall_ind { label_after; }) -> + `{record_frame i.live ~label:label_after} call {emit_reg i.arg.(0)}\n`; fill_delay_slot dslot - | Lop(Icall_imm s) -> - `{record_frame i.live} call {emit_symbol s}\n`; + | Lop(Icall_imm { func; label_after; }) -> + `{record_frame i.live ~label:label_after} call {emit_symbol func}\n`; fill_delay_slot dslot - | Lop(Itailcall_ind) -> + | Lop(Itailcall_ind { label_after = _; }) -> let n = frame_size() in if !contains_calls then ` ld [%sp + {emit_int(n - 4 + 96)}], %o7\n`; ` jmp {emit_reg i.arg.(0)}\n`; ` add %sp, {emit_int n}, %sp\n` (* in delay slot *) - | Lop(Itailcall_imm s) -> + | Lop(Itailcall_imm { func; label_after = _; }) -> let n = frame_size() in - if s = !function_name then begin + if func = !function_name then begin ` b {emit_label !tailrec_entry_point}\n`; fill_delay_slot dslot end else begin if !contains_calls then ` ld [%sp + {emit_int(n - 4 + 96)}], %o7\n`; - ` sethi %hi({emit_symbol s}), %g1\n`; - ` jmp %g1 + %lo({emit_symbol s})\n`; + ` sethi %hi({emit_symbol func}), %g1\n`; + ` jmp %g1 + %lo({emit_symbol func})\n`; ` add %sp, {emit_int n}, %sp\n` (* in delay slot *) end - | Lop(Iextcall(s, alloc)) -> + | Lop(Iextcall { func; alloc; label_after; }) -> if alloc then begin - ` sethi %hi({emit_symbol s}), %g2\n`; - `{record_frame i.live} call {emit_symbol "caml_c_call"}\n`; - ` or %g2, %lo({emit_symbol s}), %g2\n` (* in delay slot *) + ` sethi %hi({emit_symbol func}), %g2\n`; + `{record_frame i.live ~label:label_after} call {emit_symbol "caml_c_call"}\n`; + ` or %g2, %lo({emit_symbol func}), %g2\n` (* in delay slot *) end else begin - ` call {emit_symbol s}\n`; + ` call {emit_symbol func}\n`; fill_delay_slot dslot end | Lop(Istackoffset n) -> @@ -406,7 +408,7 @@ let rec emit_instr i dslot = | _ -> "st" in emit_store storeinstr addr i.arg src end - | Lop(Ialloc n) -> + | Lop(Ialloc { words = n; label_after_call_gc; }) -> if !fastcode_flag then begin let lbl_cont = new_label() in if solaris then begin @@ -419,7 +421,7 @@ let rec emit_instr i dslot = end; ` bgeu {emit_label lbl_cont}\n`; ` add %l6, 4, {emit_reg i.res.(0)}\n`; (* in delay slot *) - `{record_frame i.live} call {emit_symbol "caml_call_gc"}\n`; + `{record_frame i.live ?label:label_after_call_gc} call {emit_symbol "caml_call_gc"}\n`; ` mov {emit_int n}, %g2\n`; (* in delay slot *) ` add %l6, 4, {emit_reg i.res.(0)}\n`; `{emit_label lbl_cont}:\n` @@ -443,7 +445,7 @@ let rec emit_instr i dslot = ` mov 0, {emit_reg i.res.(0)}\n`; `{emit_label lbl}:\n` end - | Lop(Iintop Icheckbound) -> + | Lop(Iintop (Icheckbound _)) -> ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; if solaris then ` tleu 5\n` (* 5 = ST_RANGE_CHECK *) @@ -479,7 +481,7 @@ let rec emit_instr i dslot = ` mov 0, {emit_reg i.res.(0)}\n`; `{emit_label lbl}:\n` end - | Lop(Iintop_imm(Icheckbound, n)) -> + | Lop(Iintop_imm(Icheckbound _, n)) -> ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; if solaris then ` tleu 5\n` (* 5 = ST_RANGE_CHECK *) @@ -514,7 +516,7 @@ let rec emit_instr i dslot = ` st %f30, [%sp + 96]\n`; ` ld [%sp + 96], {emit_reg i.res.(0)}\n`; ` add %sp, 8, %sp\n` - | Lop(Ispecific sop) -> + | Lop(Ispecific _) -> assert false | Lreloadretaddr -> let n = frame_size() in @@ -613,7 +615,7 @@ and fill_delay_slot = function that does not branch. *) let is_one_instr_op = function - Imulh | Idiv | Imod | Icomp _ | Icheckbound -> false + Imulh | Idiv | Imod | Icomp _ | Icheckbound _ -> false | _ -> true let is_one_instr i = @@ -622,7 +624,7 @@ let is_one_instr i = begin match op with Imove | Ispill | Ireload -> i.arg.(0).typ <> Float && i.res.(0).typ <> Float - | Iconst_int n | Iconst_blockheader n -> is_native_immediate n + | Iconst_int n -> is_native_immediate n | Istackoffset _ -> true | Iload(_, Iindexed n) -> i.res.(0).typ <> Float && is_immediate n | Istore(_, Iindexed n, _) -> i.arg.(0).typ <> Float && is_immediate n @@ -650,15 +652,16 @@ let no_interference res arg = let rec emit_all i = match i with {desc = Lend} -> () - | {next = {desc = Lop(Icall_imm _) | Lop(Iextcall(_, false)) | Lbranch _}} + | {next = {desc = Lop(Icall_imm _) + | Lop(Iextcall { alloc = false; }) | Lbranch _}} when is_one_instr i -> emit_instr i.next (Some i); emit_all i.next.next - | {next = {desc = Lop(Itailcall_imm s)}} - when s = !function_name && is_one_instr i -> + | {next = {desc = Lop(Itailcall_imm { func; _ })}} + when func = !function_name && is_one_instr i -> emit_instr i.next (Some i); emit_all i.next.next - | {next = {desc = Lop(Icall_ind)}} + | {next = {desc = Lop(Icall_ind _)}} when is_one_instr i && no_interference i.res i.next.arg -> emit_instr i.next (Some i); emit_all i.next.next @@ -708,8 +711,6 @@ let emit_item = function ` .global {emit_symbol s}\n`; | Cdefine_symbol s -> `{emit_symbol s}:\n` - | Cdefine_label lbl -> - `{emit_data_label lbl}:\n` | Cint8 n -> ` .byte {emit_int n}\n` | Cint16 n -> @@ -724,8 +725,6 @@ let emit_item = function emit_float64_split_directive ".word" (Int64.bits_of_float f) | Csymbol_address s -> ` .word {emit_symbol s}\n` - | Clabel_address lbl -> - ` .word {emit_data_label lbl}\n` | Cstring s -> emit_string_directive " .ascii " s | Cskip n -> diff --git a/asmcomp/sparc/proc.ml b/asmcomp/sparc/proc.ml index 78062f31..04f3b19c 100644 --- a/asmcomp/sparc/proc.ml +++ b/asmcomp/sparc/proc.ml @@ -103,6 +103,8 @@ let phys_reg n = let stack_slot slot ty = Reg.at_location ty (Stack slot) +let loc_spacetime_node_hole = Reg.dummy (* Spacetime unsupported *) + (* Calling conventions *) let calling_conventions first_int last_int first_float last_float make_stack @@ -134,16 +136,16 @@ let calling_conventions first_int last_int first_float last_float make_stack let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs -let not_supported ofs = fatal_error "Proc.loc_results: cannot call" +let not_supported _ofs = fatal_error "Proc.loc_results: cannot call" let max_arguments_for_tailcalls = 10 let loc_arguments arg = calling_conventions 6 15 100 105 outgoing arg let loc_parameters arg = - let (loc, ofs) = calling_conventions 6 15 100 105 incoming arg in loc + let (loc, _ofs) = calling_conventions 6 15 100 105 incoming arg in loc let loc_results res = - let (loc, ofs) = calling_conventions 0 5 100 105 not_supported res in loc + let (loc, _ofs) = calling_conventions 0 5 100 105 not_supported res in loc (* On the Sparc, all arguments to C functions, even floating-point arguments, are passed in %o0..%o5, then on the stack *) @@ -187,13 +189,13 @@ let loc_external_arguments arg = (loc, Misc.align (!ofs + 4) 8) let loc_external_results res = - let (loc, ofs) = calling_conventions 0 1 100 100 not_supported res in loc + let (loc, _ofs) = calling_conventions 0 1 100 100 not_supported res in loc let loc_exn_bucket = phys_reg 0 (* $o0 *) (* Volatile registers: none *) -let regs_are_volatile rs = false +let regs_are_volatile _rs = false (* Registers destroyed by operations *) @@ -204,8 +206,9 @@ let destroyed_at_c_call = (* %l0-%l4, %i0-%i5 preserved *) 108; 109; 110; 111; 112; 113; 114]) let destroyed_at_oper = function - Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs - | Iop(Iextcall(_, false)) -> destroyed_at_c_call + Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; }) -> + all_phys_regs + | Iop(Iextcall { alloc = false; }) -> destroyed_at_c_call | _ -> [||] let destroyed_at_raise = all_phys_regs @@ -213,20 +216,20 @@ let destroyed_at_raise = all_phys_regs (* Maximal register pressure *) let safe_register_pressure = function - Iextcall(_, _) -> 0 + Iextcall _ -> 0 | _ -> 15 let max_register_pressure = function - Iextcall(_, _) -> [| 11; 0 |] + Iextcall _ -> [| 11; 0 |] | _ -> [| 19; 15 |] (* Pure operations (without any side effect besides updating their result registers). *) let op_is_pure = function - | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _ | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ - | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> false + | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _) -> false | _ -> true (* Layout of the stack *) diff --git a/asmcomp/sparc/scheduling.ml b/asmcomp/sparc/scheduling.ml index 5935ebf7..c169b475 100644 --- a/asmcomp/sparc/scheduling.ml +++ b/asmcomp/sparc/scheduling.ml @@ -49,9 +49,9 @@ method oper_issue_cycles = function | Iconst_symbol _ -> 2 | Ialloc _ -> 6 | Iintop(Icomp _) -> 4 - | Iintop(Icheckbound) -> 2 + | Iintop(Icheckbound _) -> 2 | Iintop_imm(Icomp _, _) -> 4 - | Iintop_imm(Icheckbound, _) -> 2 + | Iintop_imm(Icheckbound _, _) -> 2 | Inegf -> 2 | Iabsf -> 2 | Ifloatofint -> 6 diff --git a/asmcomp/sparc/selection.ml b/asmcomp/sparc/selection.ml index 288c0cb6..c78a5f65 100644 --- a/asmcomp/sparc/selection.ml +++ b/asmcomp/sparc/selection.ml @@ -26,7 +26,7 @@ inherit Selectgen.selector_generic as super method is_immediate n = (n <= 4095) && (n >= -4096) -method select_addressing chunk = function +method select_addressing _chunk = function Cconst_symbol s -> (Ibased(s, 0), Ctuple []) | Cop((Caddv | Cadda), [Cconst_symbol s; Cconst_int n]) -> @@ -38,6 +38,9 @@ method select_addressing chunk = function | arg -> (Iindexed 0, arg) +method private iextcall (func, alloc) = + Iextcall { func; alloc; label_after = Cmm.new_label (); } + method! select_operation op args = match (op, args) with (* For SPARC V7 multiplication, division and modulus are turned into @@ -45,11 +48,11 @@ method! select_operation op args = For SPARC V8 and V9, use hardware multiplication and division, but C library routine for modulus. *) (Cmuli, _) when !arch_version = SPARC_V7 -> - (Iextcall(".umul", false), args) + (self#iextcall(".umul", false), args) | (Cdivi, _) when !arch_version = SPARC_V7 -> - (Iextcall(".div", false), args) + (self#iextcall(".div", false), args) | (Cmodi, _) -> - (Iextcall(".rem", false), args) + (self#iextcall(".rem", false), args) | _ -> super#select_operation op args diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml index 7c755fce..d7a05697 100644 --- a/asmcomp/spill.ml +++ b/asmcomp/spill.ml @@ -72,7 +72,7 @@ let add_superpressure_regs op live_regs res_regs spilled = (fun r -> if Reg.Set.mem r spilled then () else begin match r.loc with - Stack s -> () + Stack _ -> () | _ -> let c = Proc.register_class r in pressure.(c) <- pressure.(c) + 1 end) @@ -139,10 +139,10 @@ let rec reload i before = match i.desc with Iend -> (i, before) - | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> + | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) -> (add_reloads (Reg.inter_set_array before i.arg) i, Reg.Set.empty) - | Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> + | Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; }) -> (* All regs live across must be spilled *) let (new_next, finally) = reload i.next i.live in (add_reloads (Reg.inter_set_array before i.arg) @@ -286,7 +286,7 @@ let rec spill i finally = match i.desc with Iend -> (i, finally) - | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> + | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) -> (i, Reg.Set.empty) | Iop Ireload -> let (new_next, after) = spill i.next finally in @@ -298,8 +298,8 @@ let rec spill i finally = let before1 = Reg.diff_set_array after i.res in let before = match i.desc with - Iop Icall_ind | Iop(Icall_imm _) | Iop(Iextcall _) - | Iop(Iintop Icheckbound) | Iop(Iintop_imm(Icheckbound, _)) -> + Iop Icall_ind _ | Iop(Icall_imm _) | Iop(Iextcall _) + | Iop(Iintop (Icheckbound _)) | Iop(Iintop_imm((Icheckbound _), _)) -> Reg.Set.union before1 !spill_at_raise | _ -> before1 in @@ -412,4 +412,6 @@ let fundecl f = fun_args = f.fun_args; fun_body = new_body; fun_fast = f.fun_fast; - fun_dbg = f.fun_dbg } + fun_dbg = f.fun_dbg; + fun_spacetime_shape = f.fun_spacetime_shape; + } diff --git a/asmcomp/split.ml b/asmcomp/split.ml index bac047e9..00b009ec 100644 --- a/asmcomp/split.ml +++ b/asmcomp/split.ml @@ -87,8 +87,8 @@ let identify_sub sub1 sub2 reg = let merge_substs sub1 sub2 i = match (sub1, sub2) with (None, None) -> None - | (Some s1, None) -> sub1 - | (None, Some s2) -> sub2 + | (Some _, None) -> sub1 + | (None, Some _) -> sub2 | (Some s1, Some s2) -> Reg.Set.iter (identify_sub s1 s2) (Reg.add_set_array i.live i.arg); sub1 @@ -125,8 +125,8 @@ let rec rename i sub = match i.desc with Iend -> (i, sub) - | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> - (instr_cons i.desc (subst_regs i.arg sub) [||] i.next, + | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) -> + (instr_cons_debug i.desc (subst_regs i.arg sub) [||] i.dbg i.next, None) | Iop Ireload when i.res.(0).loc = Unknown -> begin match sub with @@ -155,9 +155,9 @@ let rec rename i sub = | Iswitch(index, cases) -> let new_sub_cases = Array.map (fun c -> rename c sub) cases in let sub_merge = - merge_subst_array (Array.map (fun (n, s) -> s) new_sub_cases) i.next in + merge_subst_array (Array.map (fun (_n, s) -> s) new_sub_cases) i.next in let (new_next, sub_next) = rename i.next sub_merge in - (instr_cons (Iswitch(index, Array.map (fun (n, s) -> n) new_sub_cases)) + (instr_cons (Iswitch(index, Array.map (fun (n, _s) -> n) new_sub_cases)) (subst_regs i.arg sub) [||] new_next, sub_next) | Iloop(body) -> @@ -206,7 +206,7 @@ let fundecl f = reset (); let new_args = Array.copy f.fun_args in - let (new_body, sub_body) = rename f.fun_body (Some Reg.Map.empty) in + let (new_body, _sub_body) = rename f.fun_body (Some Reg.Map.empty) in repres_regs new_args; set_repres new_body; equiv_classes := Reg.Map.empty; @@ -214,4 +214,6 @@ let fundecl f = fun_args = new_args; fun_body = new_body; fun_fast = f.fun_fast; - fun_dbg = f.fun_dbg } + fun_dbg = f.fun_dbg; + fun_spacetime_shape = f.fun_spacetime_shape; + } diff --git a/asmcomp/strmatch.ml b/asmcomp/strmatch.ml index 7af65f64..720bd645 100644 --- a/asmcomp/strmatch.ml +++ b/asmcomp/strmatch.ml @@ -368,7 +368,7 @@ module Make(I:I) = struct (* Module entry point *) let catch arg k = match arg with - | Cexit (e,[]) -> k arg + | Cexit (_e,[]) -> k arg | _ -> let e = next_raise_count () in Ccatch (e,[],k (Cexit (e,[])),arg) diff --git a/asmcomp/un_anf.ml b/asmcomp/un_anf.ml index 15864c8b..b87ac249 100644 --- a/asmcomp/un_anf.ml +++ b/asmcomp/un_anf.ml @@ -101,8 +101,7 @@ let make_ident_info (clam : Clambda.ulambda) : ident_info = | Uoffset (expr, offset) -> loop expr; ignore_int offset - | Ulet (ident, def, body) -> - ignore ident; + | Ulet (_let_kind, _value_kind, _ident, def, body) -> loop def; loop body | Uletrec (defs, body) -> @@ -267,7 +266,7 @@ let let_bound_vars_that_can_be_moved ident_info (clam : Clambda.ulambda) = (* [expr] should usually be a variable. *) examine_argument_list [expr]; ignore_int offset - | Ulet (ident, def, body) -> + | Ulet (_let_kind, _value_kind, ident, def, body) -> begin match def with | Uconst _ -> (* The defining expression is obviously constant, so we don't @@ -429,13 +428,14 @@ let rec substitute_let_moveable is_let_moveable env (clam : Clambda.ulambda) | Uoffset (clam, n) -> let clam = substitute_let_moveable is_let_moveable env clam in Uoffset (clam, n) - | Ulet (id, def, body) -> + | Ulet (let_kind, value_kind, id, def, body) -> let def = substitute_let_moveable is_let_moveable env def in if Ident.Set.mem id is_let_moveable then let env = Ident.Map.add id def env in substitute_let_moveable is_let_moveable env body else - Ulet (id, def, substitute_let_moveable is_let_moveable env body) + Ulet (let_kind, value_kind, + id, def, substitute_let_moveable is_let_moveable env body) | Uletrec (defs, body) -> let defs = List.map (fun (id, def) -> @@ -520,18 +520,25 @@ and substitute_let_moveable_array is_let_moveable env clams = (* We say that an expression is "moveable" iff it has neither effects nor coeffects. (See semantics_of_primitives.mli.) *) -type moveable = Fixed | Moveable | Moveable_not_into_loops +type moveable = Fixed | Constant | Moveable | Moveable_not_into_loops let both_moveable a b = match a, b with + | Constant, Constant -> Constant + | Constant, Moveable + | Moveable, Constant | Moveable, Moveable -> Moveable + | Moveable_not_into_loops, Constant | Moveable_not_into_loops, Moveable + | Constant, Moveable_not_into_loops | Moveable, Moveable_not_into_loops | Moveable_not_into_loops, Moveable_not_into_loops -> Moveable_not_into_loops + | Constant, Fixed | Moveable, Fixed | Moveable_not_into_loops, Fixed - | Fixed, Moveable_not_into_loops + | Fixed, Constant | Fixed, Moveable + | Fixed, Moveable_not_into_loops | Fixed, Fixed -> Fixed let primitive_moveable (prim : Lambda.primitive) @@ -559,7 +566,7 @@ let primitive_moveable (prim : Lambda.primitive) | Arbitrary_effects, No_coeffects | Arbitrary_effects, Has_coeffects -> Fixed -type moveable_for_env = Moveable | Moveable_not_into_loops +type moveable_for_env = Constant | Moveable | Moveable_not_into_loops (** Called when we are entering a loop or body of a function (which may be called multiple times). The environment is rewritten such that @@ -567,6 +574,7 @@ type moveable_for_env = Moveable | Moveable_not_into_loops let going_into_loop env = Ident.Map.filter_map env ~f:(fun _var ((moveable : moveable_for_env), def) -> match moveable with + | Constant -> Some (Constant, def) | Moveable -> Some (Moveable, def) | Moveable_not_into_loops -> None) @@ -577,6 +585,7 @@ let rec un_anf_and_moveable ident_info env (clam : Clambda.ulambda) match clam with | Uvar id -> begin match Ident.Map.find id env with + | Constant, def -> def, Constant | Moveable, def -> def, Moveable | Moveable_not_into_loops, def -> def, Moveable_not_into_loops | exception Not_found -> @@ -590,7 +599,7 @@ let rec un_anf_and_moveable ident_info env (clam : Clambda.ulambda) end | Uconst _ -> (* Constant closures are rewritten separately. *) - clam, Moveable + clam, Constant | Udirect_apply (label, args, dbg) -> let args = un_anf_list ident_info env args in Udirect_apply (label, args, dbg), Fixed @@ -613,40 +622,46 @@ let rec un_anf_and_moveable ident_info env (clam : Clambda.ulambda) both_moveable moveable Moveable_not_into_loops | Uoffset (clam, n) -> let clam, moveable = un_anf_and_moveable ident_info env clam in - Uoffset (clam, n), moveable - | Ulet (id, def, Uvar id') when Ident.same id id' -> + Uoffset (clam, n), both_moveable Moveable moveable + | Ulet (_let_kind, _value_kind, id, def, Uvar id') when Ident.same id id' -> un_anf_and_moveable ident_info env def - | Ulet (id, def, body) -> + | Ulet (let_kind, value_kind, id, def, body) -> let def, def_moveable = un_anf_and_moveable ident_info env def in let is_linear = Ident.Set.mem id ident_info.linear in let is_used = Ident.Set.mem id ident_info.used in - begin match def_moveable, is_linear, is_used with - | (Moveable | Moveable_not_into_loops), _, false -> + let is_assigned = Ident.Set.mem id ident_info.assigned in + begin match def_moveable, is_linear, is_used, is_assigned with + | (Constant | Moveable | Moveable_not_into_loops), _, false, _ -> (* A moveable expression that is never used may be eliminated. *) un_anf_and_moveable ident_info env body - | Moveable, true, true -> - (* A moveable expression bound to a linear [Ident.t] may replace the - single occurrence of the identifier. *) - let env = - let def_moveable : moveable_for_env = - match def_moveable with - | Moveable -> Moveable - | Moveable_not_into_loops -> Moveable_not_into_loops - | Fixed -> assert false - in - Ident.Map.add id (def_moveable, def) env + | Constant, _, true, false + (* A constant expression bound to an unassigned identifier can replace any + occurances of the identifier. *) + | Moveable, true, true, false -> + (* A moveable expression bound to a linear unassigned [Ident.t] + may replace the single occurrence of the identifier. *) + let def_moveable = + match def_moveable with + | Moveable -> Moveable + | Constant -> Constant + | Moveable_not_into_loops -> Moveable_not_into_loops + | Fixed -> assert false in + let env = Ident.Map.add id (def_moveable, def) env in un_anf_and_moveable ident_info env body - | Moveable_not_into_loops, true, true + | Moveable_not_into_loops, true, true, false (* We can't delete the [let] binding in this case because we don't know whether the variable was substituted for its definition (in the case of its linear use not being inside a loop) or not. We could extend the code to cope with this case. *) - | (Moveable | Moveable_not_into_loops), false, true + | (Constant | Moveable | Moveable_not_into_loops), _, _, true + (* Constant or Moveable but assigned. *) + | (Moveable | Moveable_not_into_loops), false, _, _ (* Moveable but not used linearly. *) - | Fixed, _, _ -> + | Fixed, _, _, _ -> let body, body_moveable = un_anf_and_moveable ident_info env body in - Ulet (id, def, body), both_moveable def_moveable body_moveable + Ulet (let_kind, value_kind, id, def, body), + both_moveable def_moveable body_moveable end | Uletrec (defs, body) -> let defs = diff --git a/asmcomp/x86_dsl.ml b/asmcomp/x86_dsl.ml index 6351c6a7..e647f66c 100644 --- a/asmcomp/x86_dsl.ml +++ b/asmcomp/x86_dsl.ml @@ -50,6 +50,7 @@ let ax = Reg16 RAX let rax = Reg64 RAX let r10 = Reg64 R10 let r11 = Reg64 R11 +let r13 = Reg64 R13 let r14 = Reg64 R14 let r15 = Reg64 R15 let rsp = Reg64 RSP diff --git a/asmcomp/x86_dsl.mli b/asmcomp/x86_dsl.mli index d73770b2..080331fc 100644 --- a/asmcomp/x86_dsl.mli +++ b/asmcomp/x86_dsl.mli @@ -39,6 +39,7 @@ val ax: arg val rax: arg val r10: arg val r11: arg +val r13: arg val r14: arg val r15: arg val rsp: arg diff --git a/asmrun/.depend b/asmrun/.depend index 7840f9c2..276dd8b0 100644 --- a/asmrun/.depend +++ b/asmrun/.depend @@ -11,7 +11,8 @@ array.o: array.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ - ../byterun/caml/signals.h + ../byterun/caml/signals.h spacetime.h ../byterun/caml/io.h \ + ../byterun/caml/stack.h backtrace.o: backtrace.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ @@ -27,7 +28,8 @@ backtrace_prim.o: backtrace_prim.c ../byterun/caml/alloc.h \ ../byterun/caml/exec.h ../byterun/caml/backtrace_prim.h \ ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ - ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h stack.h + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/stack.h callback.o: callback.c ../byterun/caml/callback.h \ ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ @@ -45,7 +47,7 @@ compact.o: compact.c ../byterun/caml/address_class.h \ ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ ../byterun/caml/minor_gc.h ../byterun/caml/gc_ctrl.h \ - ../byterun/caml/weak.h + ../byterun/caml/weak.h ../byterun/caml/compact.h compare.o: compare.c ../byterun/caml/custom.h ../byterun/caml/mlvalues.h \ ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ @@ -87,13 +89,14 @@ fail.o: fail.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ ../byterun/caml/memory.h ../byterun/caml/major_gc.h \ ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ ../byterun/caml/address_class.h ../byterun/caml/printexc.h \ - ../byterun/caml/signals.h stack.h ../byterun/caml/roots.h \ - ../byterun/caml/callback.h + ../byterun/caml/signals.h ../byterun/caml/stack.h \ + ../byterun/caml/roots.h ../byterun/caml/callback.h finalise.o: finalise.c ../byterun/caml/callback.h \ ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ - ../byterun/caml/misc.h ../byterun/caml/fail.h ../byterun/caml/roots.h \ - ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/misc.h ../byterun/caml/compact.h \ + ../byterun/caml/fail.h ../byterun/caml/finalise.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ ../byterun/caml/signals.h @@ -120,8 +123,8 @@ gc_ctrl.o: gc_ctrl.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ - ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h stack.h \ - ../byterun/caml/startup_aux.h + ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \ + ../byterun/caml/stack.h ../byterun/caml/startup_aux.h globroots.o: globroots.c ../byterun/caml/memory.h \ ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/../../config/s.h ../byterun/caml/gc.h \ @@ -173,8 +176,8 @@ main.o: main.c ../byterun/caml/misc.h ../byterun/caml/config.h \ ../byterun/caml/mlvalues.h ../byterun/caml/sys.h major_gc.o: major_gc.c ../byterun/caml/compact.h ../byterun/caml/config.h \ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ - ../byterun/caml/misc.h ../byterun/caml/custom.h \ - ../byterun/caml/mlvalues.h ../byterun/caml/fail.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h \ ../byterun/caml/finalise.h ../byterun/caml/roots.h \ ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ @@ -227,17 +230,19 @@ natdynlink.o: natdynlink.c ../byterun/caml/misc.h \ ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ - ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h stack.h \ - ../byterun/caml/callback.h ../byterun/caml/alloc.h \ - ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/osdeps.h \ - ../byterun/caml/fail.h ../byterun/caml/signals.h + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/stack.h ../byterun/caml/callback.h \ + ../byterun/caml/alloc.h ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/osdeps.h ../byterun/caml/fail.h \ + ../byterun/caml/signals.h ../byterun/caml/hooks.h obj.o: obj.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/interp.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \ - ../byterun/caml/address_class.h ../byterun/caml/prims.h + ../byterun/caml/address_class.h ../byterun/caml/prims.h spacetime.h \ + ../byterun/caml/io.h ../byterun/caml/stack.h parsing.o: parsing.c ../byterun/caml/config.h \ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ @@ -257,7 +262,8 @@ roots.o: roots.c ../byterun/caml/finalise.h ../byterun/caml/roots.h \ ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \ ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ - ../byterun/caml/address_class.h ../byterun/caml/globroots.h stack.h + ../byterun/caml/address_class.h ../byterun/caml/globroots.h \ + ../byterun/caml/stack.h signals.o: signals.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ @@ -275,7 +281,41 @@ signals_asm.o: signals_asm.c ../byterun/caml/fail.h \ ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \ ../byterun/caml/signals.h ../byterun/caml/signals_machdep.h \ - signals_osdep.h stack.h + signals_osdep.h ../byterun/caml/stack.h spacetime.h \ + ../byterun/caml/io.h +spacetime.o: spacetime.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \ + ../byterun/caml/backtrace.h ../byterun/caml/exec.h \ + ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \ + ../byterun/caml/io.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/roots.h ../byterun/caml/signals.h \ + ../byterun/caml/stack.h ../byterun/caml/sys.h spacetime.h +spacetime_offline.o: spacetime_offline.c ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/gc.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/roots.h \ + ../byterun/caml/signals.h ../byterun/caml/stack.h \ + ../byterun/caml/sys.h spacetime.h ../config/s.h +spacetime_snapshot.o: spacetime_snapshot.c ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \ + ../byterun/caml/backtrace.h ../byterun/caml/exec.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h \ + ../byterun/caml/io.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/roots.h ../byterun/caml/signals.h \ + ../byterun/caml/stack.h ../byterun/caml/sys.h spacetime.h startup.o: startup.c ../byterun/caml/callback.h \ ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ @@ -287,8 +327,8 @@ startup.o: startup.c ../byterun/caml/callback.h \ ../byterun/caml/io.h ../byterun/caml/memory.h \ ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \ ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \ - ../byterun/caml/printexc.h stack.h ../byterun/caml/startup_aux.h \ - ../byterun/caml/sys.h + ../byterun/caml/printexc.h ../byterun/caml/stack.h \ + ../byterun/caml/startup_aux.h ../byterun/caml/sys.h startup_aux.o: startup_aux.c ../byterun/caml/backtrace.h \ ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ @@ -310,7 +350,7 @@ sys.o: sys.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ - ../byterun/caml/sys.h + ../byterun/caml/sys.h ../byterun/caml/version.h terminfo.o: terminfo.c ../byterun/caml/config.h \ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ ../byterun/caml/alloc.h ../byterun/caml/misc.h \ @@ -322,7 +362,7 @@ unix.o: unix.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ ../byterun/caml/osdeps.h ../byterun/caml/signals.h \ - ../byterun/caml/sys.h + ../byterun/caml/sys.h ../byterun/caml/io.h weak.o: weak.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ @@ -343,7 +383,8 @@ array.p.o: array.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ - ../byterun/caml/signals.h + ../byterun/caml/signals.h spacetime.h ../byterun/caml/io.h \ + ../byterun/caml/stack.h backtrace.p.o: backtrace.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ @@ -359,7 +400,8 @@ backtrace_prim.p.o: backtrace_prim.c ../byterun/caml/alloc.h \ ../byterun/caml/exec.h ../byterun/caml/backtrace_prim.h \ ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ - ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h stack.h + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/stack.h callback.p.o: callback.c ../byterun/caml/callback.h \ ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ @@ -377,7 +419,7 @@ compact.p.o: compact.c ../byterun/caml/address_class.h \ ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ ../byterun/caml/minor_gc.h ../byterun/caml/gc_ctrl.h \ - ../byterun/caml/weak.h + ../byterun/caml/weak.h ../byterun/caml/compact.h compare.p.o: compare.c ../byterun/caml/custom.h ../byterun/caml/mlvalues.h \ ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ @@ -419,13 +461,14 @@ fail.p.o: fail.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ ../byterun/caml/memory.h ../byterun/caml/major_gc.h \ ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ ../byterun/caml/address_class.h ../byterun/caml/printexc.h \ - ../byterun/caml/signals.h stack.h ../byterun/caml/roots.h \ - ../byterun/caml/callback.h + ../byterun/caml/signals.h ../byterun/caml/stack.h \ + ../byterun/caml/roots.h ../byterun/caml/callback.h finalise.p.o: finalise.c ../byterun/caml/callback.h \ ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ - ../byterun/caml/misc.h ../byterun/caml/fail.h ../byterun/caml/roots.h \ - ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/misc.h ../byterun/caml/compact.h \ + ../byterun/caml/fail.h ../byterun/caml/finalise.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ ../byterun/caml/signals.h @@ -452,8 +495,8 @@ gc_ctrl.p.o: gc_ctrl.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ - ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h stack.h \ - ../byterun/caml/startup_aux.h + ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \ + ../byterun/caml/stack.h ../byterun/caml/startup_aux.h globroots.p.o: globroots.c ../byterun/caml/memory.h \ ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/../../config/s.h ../byterun/caml/gc.h \ @@ -505,8 +548,8 @@ main.p.o: main.c ../byterun/caml/misc.h ../byterun/caml/config.h \ ../byterun/caml/mlvalues.h ../byterun/caml/sys.h major_gc.p.o: major_gc.c ../byterun/caml/compact.h ../byterun/caml/config.h \ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ - ../byterun/caml/misc.h ../byterun/caml/custom.h \ - ../byterun/caml/mlvalues.h ../byterun/caml/fail.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h \ ../byterun/caml/finalise.h ../byterun/caml/roots.h \ ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ @@ -559,17 +602,19 @@ natdynlink.p.o: natdynlink.c ../byterun/caml/misc.h \ ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ - ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h stack.h \ - ../byterun/caml/callback.h ../byterun/caml/alloc.h \ - ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/osdeps.h \ - ../byterun/caml/fail.h ../byterun/caml/signals.h + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/stack.h ../byterun/caml/callback.h \ + ../byterun/caml/alloc.h ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/osdeps.h ../byterun/caml/fail.h \ + ../byterun/caml/signals.h ../byterun/caml/hooks.h obj.p.o: obj.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/interp.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \ - ../byterun/caml/address_class.h ../byterun/caml/prims.h + ../byterun/caml/address_class.h ../byterun/caml/prims.h spacetime.h \ + ../byterun/caml/io.h ../byterun/caml/stack.h parsing.p.o: parsing.c ../byterun/caml/config.h \ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ @@ -589,7 +634,8 @@ roots.p.o: roots.c ../byterun/caml/finalise.h ../byterun/caml/roots.h \ ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \ ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ - ../byterun/caml/address_class.h ../byterun/caml/globroots.h stack.h + ../byterun/caml/address_class.h ../byterun/caml/globroots.h \ + ../byterun/caml/stack.h signals.p.o: signals.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ @@ -607,7 +653,41 @@ signals_asm.p.o: signals_asm.c ../byterun/caml/fail.h \ ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \ ../byterun/caml/signals.h ../byterun/caml/signals_machdep.h \ - signals_osdep.h stack.h + signals_osdep.h ../byterun/caml/stack.h spacetime.h \ + ../byterun/caml/io.h +spacetime.p.o: spacetime.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \ + ../byterun/caml/backtrace.h ../byterun/caml/exec.h \ + ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \ + ../byterun/caml/io.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/roots.h ../byterun/caml/signals.h \ + ../byterun/caml/stack.h ../byterun/caml/sys.h spacetime.h +spacetime_offline.p.o: spacetime_offline.c ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/gc.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/roots.h \ + ../byterun/caml/signals.h ../byterun/caml/stack.h \ + ../byterun/caml/sys.h spacetime.h ../config/s.h +spacetime_snapshot.p.o: spacetime_snapshot.c ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \ + ../byterun/caml/backtrace.h ../byterun/caml/exec.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h \ + ../byterun/caml/io.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/roots.h ../byterun/caml/signals.h \ + ../byterun/caml/stack.h ../byterun/caml/sys.h spacetime.h startup.p.o: startup.c ../byterun/caml/callback.h \ ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ @@ -619,8 +699,8 @@ startup.p.o: startup.c ../byterun/caml/callback.h \ ../byterun/caml/io.h ../byterun/caml/memory.h \ ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \ ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \ - ../byterun/caml/printexc.h stack.h ../byterun/caml/startup_aux.h \ - ../byterun/caml/sys.h + ../byterun/caml/printexc.h ../byterun/caml/stack.h \ + ../byterun/caml/startup_aux.h ../byterun/caml/sys.h startup_aux.p.o: startup_aux.c ../byterun/caml/backtrace.h \ ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ @@ -642,7 +722,7 @@ sys.p.o: sys.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ - ../byterun/caml/sys.h + ../byterun/caml/sys.h ../byterun/caml/version.h terminfo.p.o: terminfo.c ../byterun/caml/config.h \ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ ../byterun/caml/alloc.h ../byterun/caml/misc.h \ @@ -654,7 +734,7 @@ unix.p.o: unix.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ ../byterun/caml/osdeps.h ../byterun/caml/signals.h \ - ../byterun/caml/sys.h + ../byterun/caml/sys.h ../byterun/caml/io.h weak.p.o: weak.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ @@ -675,7 +755,8 @@ array.d.o: array.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ - ../byterun/caml/signals.h + ../byterun/caml/signals.h spacetime.h ../byterun/caml/io.h \ + ../byterun/caml/stack.h backtrace.d.o: backtrace.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ @@ -691,7 +772,8 @@ backtrace_prim.d.o: backtrace_prim.c ../byterun/caml/alloc.h \ ../byterun/caml/exec.h ../byterun/caml/backtrace_prim.h \ ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ - ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h stack.h + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/stack.h callback.d.o: callback.c ../byterun/caml/callback.h \ ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ @@ -709,7 +791,7 @@ compact.d.o: compact.c ../byterun/caml/address_class.h \ ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ ../byterun/caml/minor_gc.h ../byterun/caml/gc_ctrl.h \ - ../byterun/caml/weak.h + ../byterun/caml/weak.h ../byterun/caml/compact.h compare.d.o: compare.c ../byterun/caml/custom.h ../byterun/caml/mlvalues.h \ ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ @@ -751,13 +833,14 @@ fail.d.o: fail.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ ../byterun/caml/memory.h ../byterun/caml/major_gc.h \ ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ ../byterun/caml/address_class.h ../byterun/caml/printexc.h \ - ../byterun/caml/signals.h stack.h ../byterun/caml/roots.h \ - ../byterun/caml/callback.h + ../byterun/caml/signals.h ../byterun/caml/stack.h \ + ../byterun/caml/roots.h ../byterun/caml/callback.h finalise.d.o: finalise.c ../byterun/caml/callback.h \ ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ - ../byterun/caml/misc.h ../byterun/caml/fail.h ../byterun/caml/roots.h \ - ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/misc.h ../byterun/caml/compact.h \ + ../byterun/caml/fail.h ../byterun/caml/finalise.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ ../byterun/caml/signals.h @@ -784,8 +867,8 @@ gc_ctrl.d.o: gc_ctrl.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ - ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h stack.h \ - ../byterun/caml/startup_aux.h + ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \ + ../byterun/caml/stack.h ../byterun/caml/startup_aux.h globroots.d.o: globroots.c ../byterun/caml/memory.h \ ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/../../config/s.h ../byterun/caml/gc.h \ @@ -837,8 +920,8 @@ main.d.o: main.c ../byterun/caml/misc.h ../byterun/caml/config.h \ ../byterun/caml/mlvalues.h ../byterun/caml/sys.h major_gc.d.o: major_gc.c ../byterun/caml/compact.h ../byterun/caml/config.h \ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ - ../byterun/caml/misc.h ../byterun/caml/custom.h \ - ../byterun/caml/mlvalues.h ../byterun/caml/fail.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h \ ../byterun/caml/finalise.h ../byterun/caml/roots.h \ ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ @@ -891,17 +974,19 @@ natdynlink.d.o: natdynlink.c ../byterun/caml/misc.h \ ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ - ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h stack.h \ - ../byterun/caml/callback.h ../byterun/caml/alloc.h \ - ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/osdeps.h \ - ../byterun/caml/fail.h ../byterun/caml/signals.h + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/stack.h ../byterun/caml/callback.h \ + ../byterun/caml/alloc.h ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/osdeps.h ../byterun/caml/fail.h \ + ../byterun/caml/signals.h ../byterun/caml/hooks.h obj.d.o: obj.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/interp.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \ - ../byterun/caml/address_class.h ../byterun/caml/prims.h + ../byterun/caml/address_class.h ../byterun/caml/prims.h spacetime.h \ + ../byterun/caml/io.h ../byterun/caml/stack.h parsing.d.o: parsing.c ../byterun/caml/config.h \ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ @@ -921,7 +1006,8 @@ roots.d.o: roots.c ../byterun/caml/finalise.h ../byterun/caml/roots.h \ ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \ ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ - ../byterun/caml/address_class.h ../byterun/caml/globroots.h stack.h + ../byterun/caml/address_class.h ../byterun/caml/globroots.h \ + ../byterun/caml/stack.h signals.d.o: signals.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ @@ -939,7 +1025,41 @@ signals_asm.d.o: signals_asm.c ../byterun/caml/fail.h \ ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \ ../byterun/caml/signals.h ../byterun/caml/signals_machdep.h \ - signals_osdep.h stack.h + signals_osdep.h ../byterun/caml/stack.h spacetime.h \ + ../byterun/caml/io.h +spacetime.d.o: spacetime.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \ + ../byterun/caml/backtrace.h ../byterun/caml/exec.h \ + ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \ + ../byterun/caml/io.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/roots.h ../byterun/caml/signals.h \ + ../byterun/caml/stack.h ../byterun/caml/sys.h spacetime.h +spacetime_offline.d.o: spacetime_offline.c ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/gc.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/roots.h \ + ../byterun/caml/signals.h ../byterun/caml/stack.h \ + ../byterun/caml/sys.h spacetime.h ../config/s.h +spacetime_snapshot.d.o: spacetime_snapshot.c ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \ + ../byterun/caml/backtrace.h ../byterun/caml/exec.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h \ + ../byterun/caml/io.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/roots.h ../byterun/caml/signals.h \ + ../byterun/caml/stack.h ../byterun/caml/sys.h spacetime.h startup.d.o: startup.c ../byterun/caml/callback.h \ ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ @@ -951,8 +1071,8 @@ startup.d.o: startup.c ../byterun/caml/callback.h \ ../byterun/caml/io.h ../byterun/caml/memory.h \ ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \ ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \ - ../byterun/caml/printexc.h stack.h ../byterun/caml/startup_aux.h \ - ../byterun/caml/sys.h + ../byterun/caml/printexc.h ../byterun/caml/stack.h \ + ../byterun/caml/startup_aux.h ../byterun/caml/sys.h startup_aux.d.o: startup_aux.c ../byterun/caml/backtrace.h \ ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ @@ -974,7 +1094,7 @@ sys.d.o: sys.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ - ../byterun/caml/sys.h + ../byterun/caml/sys.h ../byterun/caml/version.h terminfo.d.o: terminfo.c ../byterun/caml/config.h \ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ ../byterun/caml/alloc.h ../byterun/caml/misc.h \ @@ -986,7 +1106,7 @@ unix.d.o: unix.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ ../byterun/caml/osdeps.h ../byterun/caml/signals.h \ - ../byterun/caml/sys.h + ../byterun/caml/sys.h ../byterun/caml/io.h weak.d.o: weak.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ @@ -1007,7 +1127,8 @@ array.i.o: array.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ - ../byterun/caml/signals.h + ../byterun/caml/signals.h spacetime.h ../byterun/caml/io.h \ + ../byterun/caml/stack.h backtrace.i.o: backtrace.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ @@ -1023,7 +1144,8 @@ backtrace_prim.i.o: backtrace_prim.c ../byterun/caml/alloc.h \ ../byterun/caml/exec.h ../byterun/caml/backtrace_prim.h \ ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ - ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h stack.h + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/stack.h callback.i.o: callback.c ../byterun/caml/callback.h \ ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ @@ -1041,7 +1163,7 @@ compact.i.o: compact.c ../byterun/caml/address_class.h \ ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ ../byterun/caml/minor_gc.h ../byterun/caml/gc_ctrl.h \ - ../byterun/caml/weak.h + ../byterun/caml/weak.h ../byterun/caml/compact.h compare.i.o: compare.c ../byterun/caml/custom.h ../byterun/caml/mlvalues.h \ ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ @@ -1083,13 +1205,14 @@ fail.i.o: fail.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ ../byterun/caml/memory.h ../byterun/caml/major_gc.h \ ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ ../byterun/caml/address_class.h ../byterun/caml/printexc.h \ - ../byterun/caml/signals.h stack.h ../byterun/caml/roots.h \ - ../byterun/caml/callback.h + ../byterun/caml/signals.h ../byterun/caml/stack.h \ + ../byterun/caml/roots.h ../byterun/caml/callback.h finalise.i.o: finalise.c ../byterun/caml/callback.h \ ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ - ../byterun/caml/misc.h ../byterun/caml/fail.h ../byterun/caml/roots.h \ - ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/misc.h ../byterun/caml/compact.h \ + ../byterun/caml/fail.h ../byterun/caml/finalise.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ ../byterun/caml/signals.h @@ -1116,8 +1239,8 @@ gc_ctrl.i.o: gc_ctrl.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ - ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h stack.h \ - ../byterun/caml/startup_aux.h + ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \ + ../byterun/caml/stack.h ../byterun/caml/startup_aux.h globroots.i.o: globroots.c ../byterun/caml/memory.h \ ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/../../config/s.h ../byterun/caml/gc.h \ @@ -1169,8 +1292,8 @@ main.i.o: main.c ../byterun/caml/misc.h ../byterun/caml/config.h \ ../byterun/caml/mlvalues.h ../byterun/caml/sys.h major_gc.i.o: major_gc.c ../byterun/caml/compact.h ../byterun/caml/config.h \ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ - ../byterun/caml/misc.h ../byterun/caml/custom.h \ - ../byterun/caml/mlvalues.h ../byterun/caml/fail.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h \ ../byterun/caml/finalise.h ../byterun/caml/roots.h \ ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ @@ -1223,17 +1346,19 @@ natdynlink.i.o: natdynlink.c ../byterun/caml/misc.h \ ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ - ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h stack.h \ - ../byterun/caml/callback.h ../byterun/caml/alloc.h \ - ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/osdeps.h \ - ../byterun/caml/fail.h ../byterun/caml/signals.h + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/stack.h ../byterun/caml/callback.h \ + ../byterun/caml/alloc.h ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/osdeps.h ../byterun/caml/fail.h \ + ../byterun/caml/signals.h ../byterun/caml/hooks.h obj.i.o: obj.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/interp.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \ - ../byterun/caml/address_class.h ../byterun/caml/prims.h + ../byterun/caml/address_class.h ../byterun/caml/prims.h spacetime.h \ + ../byterun/caml/io.h ../byterun/caml/stack.h parsing.i.o: parsing.c ../byterun/caml/config.h \ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ @@ -1253,7 +1378,8 @@ roots.i.o: roots.c ../byterun/caml/finalise.h ../byterun/caml/roots.h \ ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \ ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ - ../byterun/caml/address_class.h ../byterun/caml/globroots.h stack.h + ../byterun/caml/address_class.h ../byterun/caml/globroots.h \ + ../byterun/caml/stack.h signals.i.o: signals.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ @@ -1271,7 +1397,41 @@ signals_asm.i.o: signals_asm.c ../byterun/caml/fail.h \ ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \ ../byterun/caml/signals.h ../byterun/caml/signals_machdep.h \ - signals_osdep.h stack.h + signals_osdep.h ../byterun/caml/stack.h spacetime.h \ + ../byterun/caml/io.h +spacetime.i.o: spacetime.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \ + ../byterun/caml/backtrace.h ../byterun/caml/exec.h \ + ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \ + ../byterun/caml/io.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/roots.h ../byterun/caml/signals.h \ + ../byterun/caml/stack.h ../byterun/caml/sys.h spacetime.h +spacetime_offline.i.o: spacetime_offline.c ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/gc.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/roots.h \ + ../byterun/caml/signals.h ../byterun/caml/stack.h \ + ../byterun/caml/sys.h spacetime.h ../config/s.h +spacetime_snapshot.i.o: spacetime_snapshot.c ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \ + ../byterun/caml/backtrace.h ../byterun/caml/exec.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h \ + ../byterun/caml/io.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/roots.h ../byterun/caml/signals.h \ + ../byterun/caml/stack.h ../byterun/caml/sys.h spacetime.h startup.i.o: startup.c ../byterun/caml/callback.h \ ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ @@ -1283,8 +1443,8 @@ startup.i.o: startup.c ../byterun/caml/callback.h \ ../byterun/caml/io.h ../byterun/caml/memory.h \ ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \ ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \ - ../byterun/caml/printexc.h stack.h ../byterun/caml/startup_aux.h \ - ../byterun/caml/sys.h + ../byterun/caml/printexc.h ../byterun/caml/stack.h \ + ../byterun/caml/startup_aux.h ../byterun/caml/sys.h startup_aux.i.o: startup_aux.c ../byterun/caml/backtrace.h \ ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ @@ -1306,7 +1466,7 @@ sys.i.o: sys.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/memory.h ../byterun/caml/gc.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ - ../byterun/caml/sys.h + ../byterun/caml/sys.h ../byterun/caml/version.h terminfo.i.o: terminfo.c ../byterun/caml/config.h \ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ ../byterun/caml/alloc.h ../byterun/caml/misc.h \ @@ -1318,7 +1478,7 @@ unix.i.o: unix.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ ../byterun/caml/osdeps.h ../byterun/caml/signals.h \ - ../byterun/caml/sys.h + ../byterun/caml/sys.h ../byterun/caml/io.h weak.i.o: weak.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ diff --git a/asmrun/Makefile b/asmrun/Makefile index 1673752d..9588c163 100644 --- a/asmrun/Makefile +++ b/asmrun/Makefile @@ -17,8 +17,10 @@ include ../config/Makefile CC=$(NATIVECC) FLAGS=-I../byterun -DCAML_NAME_SPACE -DNATIVE_CODE \ - -DTARGET_$(ARCH) -DMODEL_$(MODEL) -DSYS_$(SYSTEM) $(IFLEXDIR) -CFLAGS=$(FLAGS) $(NATIVECCCOMPOPTS) + -DTARGET_$(ARCH) -DMODEL_$(MODEL) -DSYS_$(SYSTEM) $(IFLEXDIR) \ + $(LIBUNWIND_INCLUDE_FLAGS) +#CFLAGS=$(FLAGS) -g -O0 +CFLAGS=$(FLAGS) -g -O0 $(NATIVECCCOMPOPTS) DFLAGS=$(FLAGS) -g -DDEBUG $(NATIVECCCOMPOPTS) IFLAGS=$(FLAGS) -DCAML_INSTR PFLAGS=$(FLAGS) -pg -DPROFILING $(NATIVECCPROFOPTS) $(NATIVECCCOMPOPTS) @@ -31,7 +33,8 @@ 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 clambda_checks.o + natdynlink.o debugger.o meta.o dynlink.o clambda_checks.o \ + spacetime.o spacetime_snapshot.o spacetime_offline.o ASMOBJS=$(ARCH).o @@ -204,7 +207,7 @@ 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 \ parsing.c gc_ctrl.c terminfo.c md5.c obj.c lexing.c printexc.c callback.c \ weak.c compact.c finalise.c meta.c custom.c main.c globroots.c \ - $(UNIX_OR_WIN32).c dynlink.c signals.c debugger.c + $(UNIX_OR_WIN32).c dynlink.c signals.c debugger.c startup_aux.c backtrace.c clean:: rm -f $(LINKEDFILES) diff --git a/asmrun/Makefile.nt b/asmrun/Makefile.nt index 39a2f7e8..b008fddc 100644 --- a/asmrun/Makefile.nt +++ b/asmrun/Makefile.nt @@ -27,7 +27,8 @@ 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) clambda_checks.$(O) + natdynlink.$(O) debugger.$(O) meta.$(O) dynlink.$(O) clambda_checks.$(O) \ + spacetime.$(O) spacetime_snapshot.$(O) spacetime_offline.$(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/amd64.S b/asmrun/amd64.S index 5b2291ea..2d77e0f4 100644 --- a/asmrun/amd64.S +++ b/asmrun/amd64.S @@ -307,6 +307,9 @@ LBL(caml_call_gc): /* Save caml_young_ptr, caml_exception_pointer */ STORE_VAR(%r15, caml_young_ptr) STORE_VAR(%r14, caml_exception_pointer) +#ifdef WITH_SPACETIME + STORE_VAR(%r13, caml_spacetime_trie_node_ptr) +#endif /* Save floating-point registers */ subq $(16*8), %rsp; CFI_ADJUST (16*8); movsd %xmm0, 0*8(%rsp) @@ -455,6 +458,11 @@ LBL(caml_c_call): popq %r12; CFI_ADJUST(-8) STORE_VAR(%r12, caml_last_return_address) STORE_VAR(%rsp, caml_bottom_of_stack) +#ifdef WITH_SPACETIME + /* Record the trie node hole pointer that corresponds to + [caml_last_return_address] */ + STORE_VAR(%r13, caml_spacetime_trie_node_ptr) +#endif subq $8, %rsp; CFI_ADJUST(8) /* equivalent to pushq %r12 */ #if !defined(SYS_mingw64) && !defined(SYS_cygwin) /* Touch the stack to trigger a recoverable segfault @@ -483,10 +491,29 @@ FUNCTION(G(caml_start_program)) /* Common code for caml_start_program and caml_callback* */ LBL(caml_start_program): /* Build a callback link */ +#ifdef WITH_SPACETIME + PUSH_VAR(caml_spacetime_trie_node_ptr) +#else subq $8, %rsp; CFI_ADJUST (8) /* stack 16-aligned */ +#endif PUSH_VAR(caml_gc_regs) PUSH_VAR(caml_last_return_address) PUSH_VAR(caml_bottom_of_stack) +#ifdef WITH_SPACETIME + /* Save arguments to caml_callback* */ + pushq %rax; CFI_ADJUST (8) + pushq %rbx; CFI_ADJUST (8) + pushq %rdi; CFI_ADJUST (8) + pushq %rsi; CFI_ADJUST (8) + /* No need to push %r12: it's callee-save. */ + movq %r12, %rdi + LEA_VAR(caml_start_program, %rsi) + call GCALL(caml_spacetime_c_to_ocaml) + popq %rsi; CFI_ADJUST (-8) + popq %rdi; CFI_ADJUST (-8) + popq %rbx; CFI_ADJUST (-8) + popq %rax; CFI_ADJUST (-8) +#endif /* Setup alloc ptr and exception ptr */ LOAD_VAR(caml_young_ptr, %r15) LOAD_VAR(caml_exception_pointer, %r14) @@ -495,6 +522,9 @@ LBL(caml_start_program): pushq %r13; CFI_ADJUST(8) pushq %r14; CFI_ADJUST(8) movq %rsp, %r14 +#ifdef WITH_SPACETIME + LOAD_VAR(caml_spacetime_trie_node_ptr, %r13) +#endif /* Call the OCaml code */ call *%r12 LBL(107): @@ -509,7 +539,11 @@ LBL(109): POP_VAR(caml_bottom_of_stack) POP_VAR(caml_last_return_address) POP_VAR(caml_gc_regs) +#ifdef WITH_SPACETIME + POP_VAR(caml_spacetime_trie_node_ptr) +#else addq $8, %rsp; CFI_ADJUST (-8); +#endif /* Restore callee-save registers. */ POP_CALLEE_SAVE_REGS /* Return to caller. */ @@ -545,8 +579,6 @@ CFI_STARTPROC popq %r14 ret LBL(110): - STORE_VAR32($0, caml_backtrace_pos) -LBL(111): movq %rax, %r12 /* Save exception bucket */ movq %rax, C_ARG_1 /* arg 1: exception bucket */ #ifdef WITH_FRAME_POINTERS @@ -568,15 +600,6 @@ LBL(111): ret CFI_ENDPROC -FUNCTION(G(caml_reraise_exn)) -CFI_STARTPROC - TESTL_VAR($1, caml_backtrace_active) - jne LBL(111) - movq %r14, %rsp - popq %r14 - ret -CFI_ENDPROC - /* Raise an exception from C */ FUNCTION(G(caml_raise_exception)) @@ -677,6 +700,22 @@ G(caml_system__frametable): .value -1 /* negative frame size => use callback link */ .value 0 /* no roots here */ .align EIGHT_ALIGN + .quad 16 + .quad 0 + .string "amd64.S" + +#ifdef WITH_SPACETIME + .data + .globl G(caml_system__spacetime_shapes) + .align EIGHT_ALIGN +G(caml_system__spacetime_shapes): + .quad G(caml_start_program) + .quad 2 /* indirect call point to OCaml code */ + .quad LBL(107) /* in caml_start_program / caml_callback* */ + .quad 0 /* end of shapes for caml_start_program */ + .quad 0 /* end of shape table */ + .align EIGHT_ALIGN +#endif #if defined(SYS_macosx) .literal16 diff --git a/asmrun/amd64nt.asm b/asmrun/amd64nt.asm index fe80895a..07ac4508 100644 --- a/asmrun/amd64nt.asm +++ b/asmrun/amd64nt.asm @@ -309,8 +309,6 @@ caml_raise_exn: pop r14 ; Recover previous exception handler ret ; Branch to handler L110: - mov caml_backtrace_pos, 0 -L111: mov r12, rax ; Save exception bucket in r12 mov rcx, rax ; Arg 1: exception bucket mov rdx, [rsp] ; Arg 2: PC of raise @@ -323,15 +321,6 @@ L111: pop r14 ; Recover previous exception handler ret ; Branch to handler - PUBLIC caml_reraise_exn - ALIGN 16 -caml_reraise_exn: - test caml_backtrace_active, 1 - jne L111 - mov rsp, r14 ; Cut stack - pop r14 ; Recover previous exception handler - ret ; Branch to handler - ; Raise an exception from C PUBLIC caml_raise_exception diff --git a/asmrun/backtrace_prim.c b/asmrun/backtrace_prim.c index 1078da1f..2ecf1591 100644 --- a/asmrun/backtrace_prim.c +++ b/asmrun/backtrace_prim.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Stack backtrace for uncaught exceptions */ #include @@ -25,21 +27,7 @@ #include "caml/memory.h" #include "caml/misc.h" #include "caml/mlvalues.h" -#include "stack.h" - -/* In order to prevent the GC from walking through the debug information - (which have no headers), we transform frame_descr pointers into - 31/63 bits ocaml integers by shifting them by 1 to the right. We do - not lose information as descr pointers are aligned. */ -value caml_val_raw_backtrace_slot(backtrace_slot pc) -{ - return Val_long((uintnat)pc>>1); -} - -backtrace_slot caml_raw_backtrace_slot_val(value v) -{ - return ((backtrace_slot)(Long_val(v)<<1)); -} +#include "caml/stack.h" /* Returns the next frame descriptor (or NULL if none is available), and updates *pc and *sp to point to the following one. */ @@ -167,49 +155,73 @@ CAMLprim value caml_get_current_callstack(value max_frames_value) for (trace_pos = 0; trace_pos < trace_size; trace_pos++) { frame_descr * descr = caml_next_frame_descriptor(&pc, &sp); Assert(descr != NULL); - Store_field(trace, trace_pos, - caml_val_raw_backtrace_slot((backtrace_slot) descr)); + Field(trace, trace_pos) = Val_backtrace_slot((backtrace_slot) descr); } } CAMLreturn(trace); } -/* Extract location information for the given frame descriptor */ -void caml_extract_location_info(backtrace_slot slot, - /*out*/ struct caml_loc_info * li) + +debuginfo caml_debuginfo_extract(backtrace_slot slot) { uintnat infoptr; - uint32_t info1, info2; frame_descr * d = (frame_descr *)slot; + if ((d->frame_size & 1) == 0) { + return NULL; + } + /* Recover debugging info */ + infoptr = ((uintnat) d + + sizeof(char *) + sizeof(short) + sizeof(short) + + sizeof(short) * d->num_live + sizeof(frame_descr *) - 1) + & -sizeof(frame_descr *); + return *((debuginfo*)infoptr); +} + +debuginfo caml_debuginfo_next(debuginfo dbg) +{ + uint32_t * infoptr; + + if (dbg == NULL) + return NULL; + + infoptr = dbg; + infoptr += 2; /* Two packed info fields */ + return *((debuginfo*)infoptr); +} + +/* Extract location information for the given frame descriptor */ +void caml_debuginfo_location(debuginfo dbg, /*out*/ struct caml_loc_info * li) +{ + uint32_t info1, info2; + /* If no debugging information available, print nothing. When everything is compiled with -g, this corresponds to compiler-inserted re-raise operations. */ - if ((d->frame_size & 1) == 0) { + if (dbg == NULL) { li->loc_valid = 0; li->loc_is_raise = 1; + li->loc_is_inlined = 0; return; } /* Recover debugging info */ - infoptr = ((uintnat) d + - sizeof(char *) + sizeof(short) + sizeof(short) + - sizeof(short) * d->num_live + sizeof(frame_descr *) - 1) - & -sizeof(frame_descr *); - info1 = ((uint32_t *)infoptr)[0]; - info2 = ((uint32_t *)infoptr)[1]; + info1 = ((uint32_t *)dbg)[0]; + info2 = ((uint32_t *)dbg)[1]; /* Format of the two info words: llllllllllllllllllll aaaaaaaa bbbbbbbbbb nnnnnnnnnnnnnnnnnnnnnnnn kk 44 36 26 2 0 (32+12) (32+4) - k ( 2 bits): 0 if it's a call, 1 if it's a raise - n (24 bits): offset (in 4-byte words) of file name relative to infoptr + k ( 2 bits): 0 if it's a call + 1 if it's a raise + n (24 bits): offset (in 4-byte words) of file name relative to dbg l (20 bits): line number a ( 8 bits): beginning of character range b (10 bits): end of character range */ li->loc_valid = 1; - li->loc_is_raise = (info1 & 3) != 0; - li->loc_filename = (char *) infoptr + (info1 & 0x3FFFFFC); + li->loc_is_raise = (info1 & 3) == 1; + li->loc_is_inlined = caml_debuginfo_next(dbg) != NULL; + li->loc_filename = (char *) dbg + (info1 & 0x3FFFFFC); li->loc_lnum = info2 >> 12; li->loc_startchr = (info2 >> 4) & 0xFF; li->loc_endchr = ((info2 & 0xF) << 6) | (info1 >> 26); diff --git a/asmrun/fail.c b/asmrun/fail.c index 4f03cc38..ba56c477 100644 --- a/asmrun/fail.c +++ b/asmrun/fail.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Raising exceptions from C. */ #include @@ -25,7 +27,7 @@ #include "caml/mlvalues.h" #include "caml/printexc.h" #include "caml/signals.h" -#include "stack.h" +#include "caml/stack.h" #include "caml/roots.h" #include "caml/callback.h" diff --git a/asmrun/i386.S b/asmrun/i386.S index 55b6947d..9e0f2bdb 100644 --- a/asmrun/i386.S +++ b/asmrun/i386.S @@ -334,8 +334,6 @@ FUNCTION(caml_raise_exn) UNDO_ALIGN_STACK(8) ret LBL(110): - movl $0, G(caml_backtrace_pos) -LBL(111): movl %eax, %esi /* Save exception bucket in esi */ movl G(caml_exception_pointer), %edi /* SP of handler */ movl 0(%esp), %eax /* PC of raise */ @@ -353,16 +351,6 @@ LBL(111): ret CFI_ENDPROC -FUNCTION(caml_reraise_exn) - CFI_STARTPROC - testl $1, G(caml_backtrace_active) - jne LBL(111) - movl G(caml_exception_pointer), %esp - popl G(caml_exception_pointer); CFI_ADJUST(-4) - UNDO_ALIGN_STACK(8) - ret - CFI_ENDPROC - /* Raise an exception from C */ FUNCTION(caml_raise_exception) diff --git a/asmrun/i386nt.asm b/asmrun/i386nt.asm index 74d3ddfd..b6730676 100644 --- a/asmrun/i386nt.asm +++ b/asmrun/i386nt.asm @@ -208,8 +208,6 @@ _caml_raise_exn: pop _caml_exception_pointer ret L110: - mov _caml_backtrace_pos, 0 -L111: mov esi, eax ; Save exception bucket in esi mov edi, _caml_exception_pointer ; SP of handler mov eax, [esp] ; PC of raise @@ -224,16 +222,7 @@ L111: pop _caml_exception_pointer ret - PUBLIC _caml_reraise_exn - ALIGN 4 -_caml_reraise_exn: - test _caml_backtrace_active, 1 - jne L111 - mov esp, _caml_exception_pointer - pop _caml_exception_pointer - ret - - ; Raise an exception from C +; Raise an exception from C PUBLIC _caml_raise_exception ALIGN 4 diff --git a/asmrun/natdynlink.c b/asmrun/natdynlink.c index a502d449..1d90b69b 100644 --- a/asmrun/natdynlink.c +++ b/asmrun/natdynlink.c @@ -13,16 +13,25 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + #include "caml/misc.h" #include "caml/mlvalues.h" #include "caml/memory.h" -#include "stack.h" +#include "caml/stack.h" #include "caml/callback.h" #include "caml/alloc.h" #include "caml/intext.h" #include "caml/osdeps.h" #include "caml/fail.h" #include "caml/signals.h" +#ifdef WITH_SPACETIME +#include "spacetime.h" +#endif + +#include "caml/hooks.h" + +CAMLexport void (*caml_natdynlink_hook)(void* handle, char* unit) = NULL; #include #include @@ -36,8 +45,6 @@ static void *getsym(void *handle, char *module, char *name){ return sym; } -extern char caml_globals_map[]; - CAMLprim value caml_natdynlink_getmap(value unit) { return (value)caml_globals_map; @@ -92,6 +99,11 @@ CAMLprim value caml_natdynlink_run(void *handle, value symbol) { sym = optsym("__frametable"); if (NULL != sym) caml_register_frametable(sym); +#ifdef WITH_SPACETIME + sym = optsym("__spacetime_shapes"); + if (NULL != sym) caml_spacetime_register_shapes(sym); +#endif + sym = optsym("__gc_roots"); if (NULL != sym) caml_register_dyn_global(sym); @@ -111,6 +123,8 @@ CAMLprim value caml_natdynlink_run(void *handle, value symbol) { caml_ext_table_add(&caml_code_fragments_table, cf); } + if( caml_natdynlink_hook != NULL ) caml_natdynlink_hook(handle,unit); + entrypoint = optsym("__entry"); if (NULL != entrypoint) result = caml_callback((value)(&entrypoint), 0); else result = Val_unit; diff --git a/asmrun/power.S b/asmrun/power.S index 7bfca532..b58391ed 100644 --- a/asmrun/power.S +++ b/asmrun/power.S @@ -380,9 +380,6 @@ FUNCTION(caml_raise_exn) /* Branch to handler */ bctr .L111: - li 0, 0 - Storeglobal32(0, caml_backtrace_pos, 11) -.L112: mr 28, 3 /* preserve exn bucket in callee-save reg */ /* arg1: exception bucket, already in r3 */ mflr 4 /* arg2: PC of raise */ @@ -398,20 +395,6 @@ FUNCTION(caml_raise_exn) b .L110 /* raise the exn */ ENDFUNCTION(caml_raise_exn) -FUNCTION(caml_reraise_exn) - Loadglobal32(0, caml_backtrace_active, 11) - cmpwi 0, 0 - bne- .L112 - /* Pop trap frame */ - lg 0, TRAP_HANDLER_OFFSET(29) - mr 1, 29 - mtctr 0 - lg 29, TRAP_PREVIOUS_OFFSET(1) - addi 1, 1, TRAP_SIZE - /* Branch to handler */ - bctr -ENDFUNCTION(caml_reraise_exn) - /* Raise an exception from C */ FUNCTION(caml_raise_exception) diff --git a/asmrun/roots.c b/asmrun/roots.c index 7bf25b2e..6307fd09 100644 --- a/asmrun/roots.c +++ b/asmrun/roots.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* To walk the memory roots for garbage collection */ #include "caml/finalise.h" @@ -22,7 +24,7 @@ #include "caml/minor_gc.h" #include "caml/misc.h" #include "caml/mlvalues.h" -#include "stack.h" +#include "caml/stack.h" #include "caml/roots.h" #include #include @@ -83,7 +85,7 @@ static frame_descr * next_frame_descr(frame_descr * d) { sizeof(char *) + sizeof(short) + sizeof(short) + sizeof(short) * d->num_live + sizeof(frame_descr *) - 1) & -sizeof(frame_descr *); - if (d->frame_size & 1) nextd += 8; + if (d->frame_size & 1) nextd += sizeof(void *); /* pointer to debuginfo */ return((frame_descr *) nextd); } @@ -332,7 +334,7 @@ void caml_oldify_local_roots (void) /* Global C roots */ caml_scan_global_young_roots(&caml_oldify_one); /* Finalised values */ - caml_final_do_young_roots (&caml_oldify_one); + caml_final_oldify_young_roots (); /* Hook */ if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(&caml_oldify_one); } @@ -426,7 +428,7 @@ void caml_do_roots (scanning_action f, int do_globals) caml_scan_global_roots(f); CAML_INSTR_TIME (tmr, "major_roots/C"); /* Finalised values */ - caml_final_do_strong_roots (f); + caml_final_do_roots (f); CAML_INSTR_TIME (tmr, "major_roots/finalised"); /* Hook */ if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(f); diff --git a/asmrun/s390x.S b/asmrun/s390x.S index 175ea6a0..0af41994 100644 --- a/asmrun/s390x.S +++ b/asmrun/s390x.S @@ -110,6 +110,7 @@ caml_call_gc: .type caml_c_call, @function caml_c_call: Storeglobal(%r15, caml_bottom_of_stack) +.L101: /* Save return address */ ldgr %f15, %r14 /* Get ready to call C function (address in r7) */ @@ -125,10 +126,6 @@ caml_c_call: /* Reload allocation pointer and allocation limit*/ Loadglobal(%r11, caml_young_ptr) Loadglobal(%r10, caml_young_limit) - /* Say we are back into OCaml code */ - lgfi %r0, 0 - Storeglobal(%r0, caml_last_return_address) - /* Return to caller */ br %r14 @@ -148,9 +145,6 @@ caml_raise_exn: /* Branch to handler */ br %r1 .L110: - lgfi %r0, 0 - Storeglobal32(%r0, caml_backtrace_pos) -.L114: ldgr %f15, %r2 /* preserve exn bucket in callee-save reg */ /* arg1: exception bucket, already in r3 */ lgr %r3,%r14 /* arg2: PC of raise */ @@ -162,26 +156,12 @@ caml_raise_exn: lgdr %r2,%f15 /* restore exn bucket */ j .L111 /* raise the exn */ - .globl caml_reraise_exn - .type caml_reraise_exn, @function -caml_reraise_exn: - Loadglobal32(%r0, caml_backtrace_active) - cgfi %r0, 0 - jne .L114 - /* Pop trap frame */ - lg %r1, 0(%r13) - lgr %r15, %r13 - lg %r13, 8(%r13) - agfi %r15, 16 - /* Branch to handler */ - br %r1; - /* Raise an exception from C */ .globl caml_raise_exception .type caml_raise_exception, @function caml_raise_exception: - Loadglobal32(0, caml_backtrace_active) + Loadglobal32(%r0, caml_backtrace_active) cgfi %r0, 0 jne .L112 .L113: @@ -189,9 +169,6 @@ caml_raise_exception: Loadglobal(%r15, caml_exception_pointer) Loadglobal(%r11, caml_young_ptr) Loadglobal(%r10, caml_young_limit) - /* Say we are back into OCaml code */ - lgfi %r0, 0 - Storeglobal(%r0, caml_last_return_address) /* Pop trap frame */ lg %r1, 0(%r15) lg %r13, 8(%r15) @@ -199,6 +176,8 @@ caml_raise_exception: /* Branch to handler */ br %r1; .L112: + lgfi %r0, 0 + Storeglobal32(%r0, caml_backtrace_pos) ldgr %f15,%r2 /* preserve exn bucket in callee-save reg */ /* arg1: exception bucket, already in r2 */ Loadglobal(%r3, caml_last_return_address) /* arg2: PC of raise */ @@ -335,9 +314,12 @@ caml_callback3_exn: .globl caml_ml_array_bound_error .type caml_ml_array_bound_error, @function caml_ml_array_bound_error: + /* Save return address before decrementing SP, otherwise + the frame descriptor for the call site is not correct */ + Storeglobal(%r15, caml_bottom_of_stack) lay %r15, -160(%r15) /* Reserve stack space for C call */ larl %r7, caml_array_bound_error - j caml_c_call + j .L101 .globl caml_system__code_end caml_system__code_end: diff --git a/asmrun/signals_asm.c b/asmrun/signals_asm.c index 449e2dad..d08e2dbe 100644 --- a/asmrun/signals_asm.c +++ b/asmrun/signals_asm.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Signal handling, code specific to the native-code compiler */ #if defined(TARGET_amd64) && defined (SYS_linux) @@ -27,7 +29,8 @@ #include "caml/signals.h" #include "caml/signals_machdep.h" #include "signals_osdep.h" -#include "stack.h" +#include "caml/stack.h" +#include "spacetime.h" #ifdef HAS_STACK_OVERFLOW_DETECTION #include @@ -74,6 +77,13 @@ void caml_garbage_collection(void) caml_young_ptr - caml_young_trigger < Max_young_whsize){ caml_gc_dispatch (); } + +#ifdef WITH_SPACETIME + if (caml_young_ptr == caml_young_alloc_end) { + caml_spacetime_automatic_snapshot(); + } +#endif + caml_process_pending_signals(); } diff --git a/asmrun/signals_osdep.h b/asmrun/signals_osdep.h index dc2236ab..03196167 100644 --- a/asmrun/signals_osdep.h +++ b/asmrun/signals_osdep.h @@ -137,6 +137,23 @@ #define CONTEXT_YOUNG_PTR (context->sc_r15) #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) +/****************** AMD64, NetBSD */ + +#elif defined(TARGET_amd64) && defined (SYS_netbsd) + + #include + #define DECLARE_SIGNAL_HANDLER(name) \ + static void name(int sig, siginfo_t * info, ucontext_t * context) + + #define SET_SIGACT(sigact,name) \ + sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \ + sigact.sa_flags = SA_SIGINFO + + #define CONTEXT_PC (_UC_MACHINE_PC(context)) + #define CONTEXT_EXCEPTION_POINTER (context->uc_mcontext.gregs[REG_R14]) + #define CONTEXT_YOUNG_PTR (context->uc_mcontext.gregs[REG_R15]) + #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) + /****************** I386, Linux */ #elif defined(TARGET_i386) && defined(SYS_linux_elf) @@ -305,7 +322,8 @@ /****************** PowerPC, BSD */ -#elif defined(TARGET_power) && (defined(SYS_bsd) || defined(SYS_bsd_elf)) +#elif defined(TARGET_power) && \ + (defined(SYS_bsd) || defined(SYS_bsd_elf) || defined(SYS_netbsd)) #define DECLARE_SIGNAL_HANDLER(name) \ static void name(int sig, int code, struct sigcontext * context) diff --git a/asmrun/spacetime.c b/asmrun/spacetime.c new file mode 100644 index 00000000..b5e999f5 --- /dev/null +++ b/asmrun/spacetime.c @@ -0,0 +1,1122 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Mark Shinwell and Leo White, Jane Street Europe */ +/* */ +/* Copyright 2013--2016, Jane Street Group, LLC */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include "caml/config.h" +#ifdef HAS_UNISTD +#include +#endif + +#include "caml/alloc.h" +#include "caml/backtrace_prim.h" +#include "caml/fail.h" +#include "caml/gc.h" +#include "caml/intext.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/roots.h" +#include "caml/signals.h" +#include "caml/stack.h" +#include "caml/sys.h" +#include "spacetime.h" + +#ifdef WITH_SPACETIME + +/* We force "noinline" in certain places to be sure we know how many + frames there will be on the stack. */ +#define NOINLINE __attribute__((noinline)) + +#ifdef HAS_LIBUNWIND +#define UNW_LOCAL_ONLY +#include "libunwind.h" +#endif + +static int automatic_snapshots = 0; +static double snapshot_interval = 0.0; +static double next_snapshot_time = 0.0; +static struct channel *snapshot_channel; +static int pid_when_snapshot_channel_opened; + +extern value caml_spacetime_debug(value); + +static char* start_of_free_node_block; +static char* end_of_free_node_block; + +typedef struct per_thread { + value* trie_node_root; + value* finaliser_trie_node_root; + struct per_thread* next; +} per_thread; + +/* List of tries corresponding to threads that have been created. */ +/* CR-soon mshinwell: just include the main trie in this list. */ +static per_thread* per_threads = NULL; +static int num_per_threads = 0; + +/* [caml_spacetime_shapes] is defined in the startup file. */ +extern uint64_t* caml_spacetime_shapes; + +uint64_t** caml_spacetime_static_shape_tables = NULL; +shape_table* caml_spacetime_dynamic_shape_tables = NULL; + +static uintnat caml_spacetime_profinfo = (uintnat) 0; + +value caml_spacetime_trie_root = Val_unit; +value* caml_spacetime_trie_node_ptr = &caml_spacetime_trie_root; + +static value caml_spacetime_finaliser_trie_root_main_thread = Val_unit; +value* caml_spacetime_finaliser_trie_root + = &caml_spacetime_finaliser_trie_root_main_thread; + +/* CR-someday mshinwell: think about thread safety of the manipulation of + this list for multicore */ +allocation_point* caml_all_allocation_points = NULL; + +static const uintnat chunk_size = 1024 * 1024; + +static void reinitialise_free_node_block(void) +{ + size_t index; + + start_of_free_node_block = (char*) malloc(chunk_size); + end_of_free_node_block = start_of_free_node_block + chunk_size; + + for (index = 0; index < chunk_size / sizeof(value); index++) { + ((value*) start_of_free_node_block)[index] = Val_unit; + } +} + +#ifndef O_BINARY +#define O_BINARY 0 +#endif + +#if defined (_WIN32) || defined (_WIN64) +extern value val_process_id; +#endif + +static uint32_t version_number = 0; +static uint32_t magic_number_base = 0xace00ace; + +static void caml_spacetime_write_magic_number_internal(struct channel* chan) +{ + value magic_number = + Val_long(((uint64_t) magic_number_base) + | (((uint64_t) version_number) << 32)); + + Lock(chan); + caml_output_val(chan, magic_number, Val_long(0)); + Unlock(chan); +} + +CAMLprim value caml_spacetime_write_magic_number(value v_channel) +{ + caml_spacetime_write_magic_number_internal(Channel(v_channel)); + return Val_unit; +} + +static char* automatic_snapshot_dir; + +static void open_snapshot_channel(void) +{ + int fd; + char filename[8192]; + int pid; +#if defined (_WIN32) || defined (_WIN64) + pid = Int_val(val_process_id); +#else + pid = getpid(); +#endif + snprintf(filename, 8192, "%s/spacetime-%d", automatic_snapshot_dir, pid); + filename[8191] = '\0'; + fd = open(filename, O_WRONLY | O_CREAT | O_TRUNC | O_BINARY, 0666); + if (fd == -1) { + automatic_snapshots = 0; + } + else { + snapshot_channel = caml_open_descriptor_out(fd); + snapshot_channel->flags |= CHANNEL_FLAG_BLOCKING_WRITE; + pid_when_snapshot_channel_opened = pid; + caml_spacetime_write_magic_number_internal(snapshot_channel); + } +} + +static void maybe_reopen_snapshot_channel(void) +{ + /* This function should be used before writing to the automatic snapshot + channel. It detects whether we have forked since the channel was opened. + If so, we close the old channel (ignoring any errors just in case the + old fd has been closed, e.g. in a double-fork situation where the middle + process has a loop to manually close all fds and no Spacetime snapshot + was written during that time) and then open a new one. */ + + int pid; +#if defined (_WIN32) || defined (_WIN64) + pid = Int_val(val_process_id); +#else + pid = getpid(); +#endif + + if (pid != pid_when_snapshot_channel_opened) { + caml_close_channel(snapshot_channel); + open_snapshot_channel(); + } +} + +extern void caml_spacetime_automatic_save(void); + +void caml_spacetime_initialize(void) +{ + /* Note that this is called very early (even prior to GC initialisation). */ + + char *ap_interval; + + reinitialise_free_node_block(); + + caml_spacetime_static_shape_tables = &caml_spacetime_shapes; + + ap_interval = getenv ("OCAML_SPACETIME_INTERVAL"); + if (ap_interval != NULL) { + unsigned int interval = 0; + sscanf(ap_interval, "%u", &interval); + if (interval != 0) { + double time; + char cwd[4096]; + char* user_specified_automatic_snapshot_dir; + int dir_ok = 1; + + user_specified_automatic_snapshot_dir = + getenv("OCAML_SPACETIME_SNAPSHOT_DIR"); + + if (user_specified_automatic_snapshot_dir == NULL) { +#ifdef HAS_GETCWD + if (getcwd(cwd, sizeof(cwd)) == NULL) { + dir_ok = 0; + } +#else + if (getwd(cwd) == NULL) { + dir_ok = 0; + } +#endif + if (dir_ok) { + automatic_snapshot_dir = strdup(cwd); + } + } + else { + automatic_snapshot_dir = + strdup(user_specified_automatic_snapshot_dir); + } + + if (dir_ok) { + automatic_snapshots = 1; + open_snapshot_channel(); + if (automatic_snapshots) { +#ifdef SIGINT + /* Catch interrupt so that the profile can be completed. + We do this by marking the signal as handled without + specifying an actual handler. This causes the signal + to be handled by a call to exit. */ + caml_set_signal_action(SIGINT, 2); +#endif + snapshot_interval = interval / 1e3; + time = caml_sys_time_unboxed(Val_unit); + next_snapshot_time = time + snapshot_interval; + atexit(&caml_spacetime_automatic_save); + } + } + } + } +} + +void caml_spacetime_register_shapes(void* dynlinked_table) +{ + shape_table* table; + table = (shape_table*) malloc(sizeof(shape_table)); + if (table == NULL) { + fprintf(stderr, "Out of memory whilst registering shape table"); + abort(); + } + table->table = (uint64_t*) dynlinked_table; + table->next = caml_spacetime_dynamic_shape_tables; + caml_spacetime_dynamic_shape_tables = table; +} + +CAMLprim value caml_spacetime_trie_is_initialized (value v_unit) +{ + return (caml_spacetime_trie_root == Val_unit) ? Val_false : Val_true; +} + +CAMLprim value caml_spacetime_get_trie_root (value v_unit) +{ + return caml_spacetime_trie_root; +} + +void caml_spacetime_register_thread( + value* trie_node_root, value* finaliser_trie_node_root) +{ + per_thread* thr; + + thr = (per_thread*) malloc(sizeof(per_thread)); + if (thr == NULL) { + fprintf(stderr, "Out of memory while registering thread for profiling\n"); + abort(); + } + thr->next = per_threads; + per_threads = thr; + + thr->trie_node_root = trie_node_root; + thr->finaliser_trie_node_root = finaliser_trie_node_root; + + /* CR-soon mshinwell: record thread ID (and for the main thread too) */ + + num_per_threads++; +} + +static void caml_spacetime_save_event_internal (value v_time_opt, + struct channel* chan, + value v_event_name) +{ + value v_time; + double time_override = 0.0; + int use_time_override = 0; + + if (Is_block(v_time_opt)) { + time_override = Double_field(Field(v_time_opt, 0), 0); + use_time_override = 1; + } + v_time = caml_spacetime_timestamp(time_override, use_time_override); + + Lock(chan); + caml_output_val(chan, Val_long(2), Val_long(0)); + caml_output_val(chan, v_event_name, Val_long(0)); + caml_extern_allow_out_of_heap = 1; + caml_output_val(chan, v_time, Val_long(0)); + caml_extern_allow_out_of_heap = 0; + Unlock(chan); + + caml_stat_free(Hp_val(v_time)); +} + +CAMLprim value caml_spacetime_save_event (value v_time_opt, + value v_channel, + value v_event_name) +{ + struct channel* chan = Channel(v_channel); + + caml_spacetime_save_event_internal(v_time_opt, chan, v_event_name); + + return Val_unit; +} + + +void save_trie (struct channel *chan, double time_override, + int use_time_override) +{ + value v_time, v_frames, v_shapes; + /* CR-someday mshinwell: The commented-out changes here are for multicore, + where we think we should have one trie per domain. */ + /* int num_marshalled = 0; + per_thread* thr = per_threads; */ + + Lock(chan); + + caml_output_val(chan, Val_long(1), Val_long(0)); + + v_time = caml_spacetime_timestamp(time_override, use_time_override); + v_frames = caml_spacetime_frame_table(); + v_shapes = caml_spacetime_shape_table(); + + caml_extern_allow_out_of_heap = 1; + caml_output_val(chan, v_time, Val_long(0)); + caml_output_val(chan, v_frames, Val_long(0)); + caml_output_val(chan, v_shapes, Val_long(0)); + caml_extern_allow_out_of_heap = 0; + + caml_output_val(chan, Val_long(1) /* Val_long(num_per_threads + 1) */, + Val_long(0)); + + /* Marshal both the main and finaliser tries, for all threads that have + been created, to an [out_channel]. This can be done by using the + extern.c code as usual, since the trie looks like standard OCaml values; + but we must allow it to traverse outside the heap. */ + + caml_extern_allow_out_of_heap = 1; + caml_output_val(chan, caml_spacetime_trie_root, Val_long(0)); + caml_output_val(chan, + caml_spacetime_finaliser_trie_root_main_thread, Val_long(0)); + /* while (thr != NULL) { + caml_output_val(chan, *(thr->trie_node_root), Val_long(0)); + caml_output_val(chan, *(thr->finaliser_trie_node_root), + Val_long(0)); + thr = thr->next; + num_marshalled++; + } + Assert(num_marshalled == num_per_threads); */ + caml_extern_allow_out_of_heap = 0; + + Unlock(chan); +} + +CAMLprim value caml_spacetime_save_trie (value v_time_opt, value v_channel) +{ + struct channel* channel = Channel(v_channel); + double time_override = 0.0; + int use_time_override = 0; + + if (Is_block(v_time_opt)) { + time_override = Double_field(Field(v_time_opt, 0), 0); + use_time_override = 1; + } + + save_trie(channel, time_override, use_time_override); + + return Val_unit; +} + +c_node_type caml_spacetime_classify_c_node(c_node* node) +{ + return (node->pc & 2) ? CALL : ALLOCATION; +} + +c_node* caml_spacetime_c_node_of_stored_pointer(value node_stored) +{ + Assert(node_stored == Val_unit || Is_c_node(node_stored)); + return (node_stored == Val_unit) ? NULL : (c_node*) Hp_val(node_stored); +} + +c_node* caml_spacetime_c_node_of_stored_pointer_not_null( + value node_stored) +{ + Assert(Is_c_node(node_stored)); + return (c_node*) Hp_val(node_stored); +} + +value caml_spacetime_stored_pointer_of_c_node(c_node* c_node) +{ + value node; + Assert(c_node != NULL); + node = Val_hp(c_node); + Assert(Is_c_node(node)); + return node; +} + +#ifdef HAS_LIBUNWIND +static int pc_inside_c_node_matches(c_node* node, void* pc) +{ + return Decode_c_node_pc(node->pc) == pc; +} +#endif + +static value allocate_uninitialized_ocaml_node(int size_including_header) +{ + void* node; + uintnat size; + + Assert(size_including_header >= 3); + node = caml_stat_alloc(sizeof(uintnat) * size_including_header); + + size = size_including_header * sizeof(value); + + node = (void*) start_of_free_node_block; + if (end_of_free_node_block - start_of_free_node_block < size) { + reinitialise_free_node_block(); + node = (void*) start_of_free_node_block; + Assert(end_of_free_node_block - start_of_free_node_block >= size); + } + + start_of_free_node_block += size; + + /* We don't currently rely on [uintnat] alignment, but we do need some + alignment, so just be sure. */ + Assert (((uintnat) node) % sizeof(uintnat) == 0); + return Val_hp(node); +} + +static value find_tail_node(value node, void* callee) +{ + /* Search the tail chain within [node] (which corresponds to an invocation + of a caller of [callee]) to determine whether it contains a tail node + corresponding to [callee]. Returns any such node, or [Val_unit] if no + such node exists. */ + + value starting_node; + value pc; + value found = Val_unit; + + starting_node = node; + pc = Encode_node_pc(callee); + + do { + Assert(Is_ocaml_node(node)); + if (Node_pc(node) == pc) { + found = node; + } + else { + node = Tail_link(node); + } + } while (found == Val_unit && starting_node != node); + + return found; +} + +CAMLprim value caml_spacetime_allocate_node( + int size_including_header, void* pc, value* node_hole) +{ + value node; + value caller_node = Val_unit; + + node = *node_hole; + /* The node hole should either contain [Val_unit], indicating that this + function was not tail called and we have not been to this point in the + trie before; or it should contain a value encoded using + [Encoded_tail_caller_node] that points at the node of a caller + that tail called the current function. (Such a value is necessary to + be able to find the start of the caller's node, and hence its tail + chain, so we as a tail-called callee can link ourselves in.) */ + Assert(Is_tail_caller_node_encoded(node)); + + if (node != Val_unit) { + value tail_node; + /* The callee was tail called. Find whether there already exists a node + for it in the tail call chain within the caller's node. The caller's + node must always be an OCaml node. */ + caller_node = Decode_tail_caller_node(node); + tail_node = find_tail_node(caller_node, pc); + if (tail_node != Val_unit) { + /* This tail calling sequence has happened before; just fill the hole + with the existing node and return. */ + *node_hole = tail_node; + return 0; /* indicates an existing node was returned */ + } + } + + node = allocate_uninitialized_ocaml_node(size_including_header); + Hd_val(node) = + Make_header(size_including_header - 1, OCaml_node_tag, Caml_black); + Assert((((uintnat) pc) % 1) == 0); + Node_pc(node) = Encode_node_pc(pc); + /* If the callee was tail called, then the tail link field will link this + new node into an existing tail chain. Otherwise, it is initialized with + the empty tail chain, i.e. the one pointing directly at [node]. */ + if (caller_node == Val_unit) { + Tail_link(node) = node; + } + else { + Tail_link(node) = Tail_link(caller_node); + Tail_link(caller_node) = node; + } + + /* The callee node pointers for direct tail call points are + initialized from code emitted by the OCaml compiler. This is done to + avoid having to pass this function a description of which nodes are + direct tail call points. (We cannot just count them and put them at the + beginning of the node because we need the indexes of elements within the + node during instruction selection before we have found all call points.) + + All other fields have already been initialised by + [reinitialise_free_node_block]. + */ + + *node_hole = node; + + return 1; /* indicates a new node was created */ +} + +static c_node* allocate_c_node(void) +{ + c_node* node; + size_t index; + + node = (c_node*) start_of_free_node_block; + if (end_of_free_node_block - start_of_free_node_block < sizeof(c_node)) { + reinitialise_free_node_block(); + node = (c_node*) start_of_free_node_block; + Assert(end_of_free_node_block - start_of_free_node_block + >= sizeof(c_node)); + } + start_of_free_node_block += sizeof(c_node); + + Assert((sizeof(c_node) % sizeof(uintnat)) == 0); + + /* CR-soon mshinwell: remove this and pad the structure properly */ + for (index = 0; index < sizeof(c_node) / sizeof(value); index++) { + ((value*) node)[index] = Val_unit; + } + + node->gc_header = + Make_header(sizeof(c_node)/sizeof(uintnat) - 1, C_node_tag, Caml_black); + node->data.callee_node = Val_unit; + node->next = Val_unit; + + return node; +} + +/* Since a given indirect call site either always yields tail calls or + always yields non-tail calls, the output of + [caml_spacetime_indirect_node_hole_ptr] is uniquely determined by its + first two arguments (the callee and the node hole). We cache these + to increase performance of recursive functions containing an indirect + call (e.g. [List.map] when not inlined). */ +static void* last_indirect_node_hole_ptr_callee; +static value* last_indirect_node_hole_ptr_node_hole; +static value* last_indirect_node_hole_ptr_result; + +CAMLprim value* caml_spacetime_indirect_node_hole_ptr + (void* callee, value* node_hole, value caller_node) +{ + /* Find the address of the node hole for an indirect call to [callee]. + If [caller_node] is not [Val_unit], it is a pointer to the caller's + node, and indicates that this is a tail call site. */ + + c_node* c_node; + value encoded_callee; + + if (callee == last_indirect_node_hole_ptr_callee + && node_hole == last_indirect_node_hole_ptr_node_hole) { + return last_indirect_node_hole_ptr_result; + } + + last_indirect_node_hole_ptr_callee = callee; + last_indirect_node_hole_ptr_node_hole = node_hole; + + encoded_callee = Encode_c_node_pc_for_call(callee); + + while (*node_hole != Val_unit) { + Assert(((uintnat) *node_hole) % sizeof(value) == 0); + + c_node = caml_spacetime_c_node_of_stored_pointer_not_null(*node_hole); + + Assert(c_node != NULL); + Assert(caml_spacetime_classify_c_node(c_node) == CALL); + + if (c_node->pc == encoded_callee) { + last_indirect_node_hole_ptr_result = &(c_node->data.callee_node); + return last_indirect_node_hole_ptr_result; + } + else { + node_hole = &c_node->next; + } + } + + c_node = allocate_c_node(); + c_node->pc = encoded_callee; + + if (caller_node != Val_unit) { + /* This is a tail call site. + Perform the initialization equivalent to that emitted by + [Spacetime.code_for_function_prologue] for direct tail call + sites. */ + c_node->data.callee_node = Encode_tail_caller_node(caller_node); + } + + *node_hole = caml_spacetime_stored_pointer_of_c_node(c_node); + + Assert(((uintnat) *node_hole) % sizeof(value) == 0); + Assert(*node_hole != Val_unit); + + last_indirect_node_hole_ptr_result = &(c_node->data.callee_node); + + return last_indirect_node_hole_ptr_result; +} + +/* Some notes on why caml_call_gc doesn't need a distinguished node. + (Remember that thread switches are irrelevant here because each thread + has its own trie.) + + caml_call_gc only invokes OCaml functions in the following circumstances: + 1. running an OCaml finaliser; + 2. executing an OCaml signal handler. + Both of these are done on the finaliser trie. Furthermore, both of + these invocations start via caml_callback; the code in this file for + handling that (caml_spacetime_c_to_ocaml) correctly copes with that by + attaching a single "caml_start_program" node that can cope with any + number of indirect OCaml calls from that point. + + caml_call_gc may also invoke C functions that cause allocation. All of + these (assuming libunwind support is present) will cause a chain of + c_node structures to be attached to the trie, starting at the node hole + passed to caml_call_gc from OCaml code. These structures are extensible + and can thus accommodate any number of C backtraces leading from + caml_call_gc. +*/ +/* CR-soon mshinwell: it might in fact be the case now that nothing called + from caml_call_gc will do any allocation that ends up on the trie. We + can revisit this after the first release. */ + +static NOINLINE void* find_trie_node_from_libunwind(int for_allocation, + uintnat wosize, struct ext_table** cached_frames) +{ +#ifdef HAS_LIBUNWIND + /* Given that [caml_last_return_address] is the most recent call site in + OCaml code, and that we are now in C (or other) code called from that + site, obtain a backtrace using libunwind and graft the most recent + portion (everything back to but not including [caml_last_return_address]) + onto the trie. See the important comment below regarding the fact that + call site, and not callee, addresses are recorded during this process. + + If [for_allocation] is non-zero, the final node recorded will be for + an allocation, and the returned pointer is to the allocation node. + Otherwise, no node is recorded for the innermost frame, and the + returned pointer is a pointer to the *node hole* where a node for that + frame should be attached. + + If [for_allocation] is non-zero then [wosize] must give the size in + words, excluding the header, of the value being allocated. + + If [cached_frames != NULL] then: + 1. If [*cached_frames] is NULL then save the captured backtrace in a + newly-allocated table and store the pointer to that table in + [*cached_frames]; + 2. Otherwise use [*cached_frames] as the unwinding information. + The intention is that when the context is known (e.g. a function such + as [caml_make_vect] known to have been directly invoked from OCaml), + we can avoid expensive calls to libunwind. + */ + + unw_cursor_t cur; + unw_context_t ctx; + int ret; + int innermost_frame; + int frame; + static struct ext_table frames_local; + struct ext_table* frames; + static int ext_table_initialised = 0; + int have_frames_already = 0; + value* node_hole; + c_node* node = NULL; + int initial_table_size = 1000; + int must_initialise_node_for_allocation = 0; + + if (!cached_frames) { + if (!ext_table_initialised) { + caml_ext_table_init(&frames_local, initial_table_size); + ext_table_initialised = 1; + } + else { + caml_ext_table_clear(&frames_local, 0); + } + frames = &frames_local; + } else { + if (*cached_frames) { + frames = *cached_frames; + have_frames_already = 1; + } + else { + frames = (struct ext_table*) malloc(sizeof(struct ext_table)); + if (!frames) { + caml_fatal_error("Not enough memory for ext_table allocation"); + } + caml_ext_table_init(frames, initial_table_size); + *cached_frames = frames; + } + } + + if (!have_frames_already) { + /* Get the stack backtrace as far as [caml_last_return_address]. */ + + ret = unw_getcontext(&ctx); + if (ret != UNW_ESUCCESS) { + return NULL; + } + + ret = unw_init_local(&cur, &ctx); + if (ret != UNW_ESUCCESS) { + return NULL; + } + + while ((ret = unw_step(&cur)) > 0) { + unw_word_t ip; + unw_get_reg(&cur, UNW_REG_IP, &ip); + if (caml_last_return_address == (uintnat) ip) { + break; + } + else { + /* Inlined some of [caml_ext_table_add] for speed. */ + if (frames->size < frames->capacity) { + frames->contents[frames->size++] = (void*) ip; + } else { + caml_ext_table_add(frames, (void*) ip); + } + } + } + } + + /* We always need to ignore the frames for: + #0 find_trie_node_from_libunwind + #1 caml_spacetime_c_to_ocaml + Further, if this is not an allocation point, we should not create the + node for the current C function that triggered us (i.e. frame #2). */ + innermost_frame = for_allocation ? 1 : 2; + + if (frames->size - 1 < innermost_frame) { + /* Insufficiently many frames (maybe no frames) returned from + libunwind; just don't do anything. */ + return NULL; + } + + node_hole = caml_spacetime_trie_node_ptr; + /* Note that if [node_hole] is filled, then it must point to a C node, + since it is not possible for there to be a call point in an OCaml + function that sometimes calls C and sometimes calls OCaml. */ + + for (frame = frames->size - 1; frame >= innermost_frame; frame--) { + c_node_type expected_type; + void* pc = frames->contents[frame]; + Assert (pc != (void*) caml_last_return_address); + + if (!for_allocation) { + expected_type = CALL; + } + else { + expected_type = (frame > innermost_frame ? CALL : ALLOCATION); + } + + if (*node_hole == Val_unit) { + node = allocate_c_node(); + /* Note: for CALL nodes, the PC is the program counter at each call + site. We do not store program counter addresses of the start of + callees, unlike for OCaml nodes. This means that some trie nodes + will become conflated. These can be split during post-processing by + working out which function each call site was in. */ + node->pc = (expected_type == CALL ? Encode_c_node_pc_for_call(pc) + : Encode_c_node_pc_for_alloc_point(pc)); + *node_hole = caml_spacetime_stored_pointer_of_c_node(node); + if (expected_type == ALLOCATION) { + must_initialise_node_for_allocation = 1; + } + } + else { + c_node* prev; + int found = 0; + + node = caml_spacetime_c_node_of_stored_pointer_not_null(*node_hole); + Assert(node != NULL); + Assert(node->next == Val_unit + || (((uintnat) (node->next)) % sizeof(value) == 0)); + + prev = NULL; + + while (!found && node != NULL) { + if (caml_spacetime_classify_c_node(node) == expected_type + && pc_inside_c_node_matches(node, pc)) { + found = 1; + } + else { + prev = node; + node = caml_spacetime_c_node_of_stored_pointer(node->next); + } + } + if (!found) { + Assert(prev != NULL); + node = allocate_c_node(); + node->pc = (expected_type == CALL ? Encode_c_node_pc_for_call(pc) + : Encode_c_node_pc_for_alloc_point(pc)); + if (expected_type == ALLOCATION) { + must_initialise_node_for_allocation = 1; + } + prev->next = caml_spacetime_stored_pointer_of_c_node(node); + } + } + + Assert(node != NULL); + + Assert(caml_spacetime_classify_c_node(node) == expected_type); + Assert(pc_inside_c_node_matches(node, pc)); + node_hole = &node->data.callee_node; + } + + if (must_initialise_node_for_allocation) { + caml_spacetime_profinfo++; + if (caml_spacetime_profinfo > PROFINFO_MASK) { + /* Profiling counter overflow. */ + caml_spacetime_profinfo = PROFINFO_MASK; + } + node->data.allocation.profinfo = + Make_header_with_profinfo( + /* "-1" because [c_node] has the GC header as its first + element. */ + offsetof(c_node, data.allocation.count)/sizeof(value) - 1, + Infix_tag, + Caml_black, + caml_spacetime_profinfo); + node->data.allocation.count = Val_long(0); + + /* Add the new allocation point into the linked list of all allocation + points. */ + if (caml_all_allocation_points != NULL) { + node->data.allocation.next = + (value) &caml_all_allocation_points->count; + } else { + node->data.allocation.next = Val_unit; + } + caml_all_allocation_points = &node->data.allocation; + } + + if (for_allocation) { + Assert(caml_spacetime_classify_c_node(node) == ALLOCATION); + Assert(caml_spacetime_c_node_of_stored_pointer(node->next) != node); + Assert(Profinfo_hd(node->data.allocation.profinfo) > 0); + node->data.allocation.count = + Val_long(Long_val(node->data.allocation.count) + (1 + wosize)); + } + + Assert(node->next != (value) NULL); + + return for_allocation ? (void*) node : (void*) node_hole; +#else + return NULL; +#endif +} + +void caml_spacetime_c_to_ocaml(void* ocaml_entry_point, + void* identifying_pc_for_caml_start_program) +{ + /* Called in [caml_start_program] and [caml_callback*] when we are about + to cross from C into OCaml. [ocaml_entry_point] is the branch target. + This situation is handled by ensuring the presence of a new OCaml node + for the callback veneer; the node contains a single indirect call point + which accumulates the [ocaml_entry_point]s. + + The layout of the node is described in the "system shape table"; see + asmrun/amd64.S. + */ + + value node; + + /* Update the trie with the current backtrace, as far back as + [caml_last_return_address], and leave the node hole pointer at + the correct place for attachment of a [caml_start_program] node. */ + +#ifdef HAS_LIBUNWIND + value* node_temp; + node_temp = (value*) find_trie_node_from_libunwind(0, 0, NULL); + if (node_temp != NULL) { + caml_spacetime_trie_node_ptr = node_temp; + } +#endif + + if (*caml_spacetime_trie_node_ptr == Val_unit) { + uintnat size_including_header; + + size_including_header = + 1 /* GC header */ + Node_num_header_words + Indirect_num_fields; + + node = allocate_uninitialized_ocaml_node(size_including_header); + Hd_val(node) = + Make_header(size_including_header - 1, OCaml_node_tag, Caml_black); + Assert((((uintnat) identifying_pc_for_caml_start_program) % 1) == 0); + Node_pc(node) = Encode_node_pc(identifying_pc_for_caml_start_program); + Tail_link(node) = node; + Indirect_pc_linked_list(node, Node_num_header_words) = Val_unit; + *caml_spacetime_trie_node_ptr = node; + } + else { + node = *caml_spacetime_trie_node_ptr; + /* If there is a node here already, it should never be an initialized + (but as yet unused) tail call point, since calls from OCaml into C + are never tail calls (and no C -> C call is marked as tail). */ + Assert(!Is_tail_caller_node_encoded(node)); + } + + Assert(Is_ocaml_node(node)); + Assert(Decode_node_pc(Node_pc(node)) + == identifying_pc_for_caml_start_program); + Assert(Tail_link(node) == node); + Assert(Wosize_val(node) == Node_num_header_words + Indirect_num_fields); + + /* Search the node to find the node hole corresponding to the indirect + call to the OCaml function. */ + caml_spacetime_trie_node_ptr = + caml_spacetime_indirect_node_hole_ptr( + ocaml_entry_point, + &Indirect_pc_linked_list(node, Node_num_header_words), + Val_unit); + Assert(*caml_spacetime_trie_node_ptr == Val_unit + || Is_ocaml_node(*caml_spacetime_trie_node_ptr)); +} + +extern void caml_garbage_collection(void); /* signals_asm.c */ +extern void caml_array_bound_error(void); /* fail.c */ + +CAMLprim uintnat caml_spacetime_generate_profinfo (void* profinfo_words, + uintnat index_within_node) +{ + /* Called from code that creates a value's header inside an OCaml + function. */ + + value node; + uintnat profinfo; + + caml_spacetime_profinfo++; + if (caml_spacetime_profinfo > PROFINFO_MASK) { + /* Profiling counter overflow. */ + caml_spacetime_profinfo = PROFINFO_MASK; + } + profinfo = caml_spacetime_profinfo; + + /* CR-someday mshinwell: we could always use the [struct allocation_point] + overlay instead of the macros now. */ + + /* [node] isn't really a node; it points into the middle of + one---specifically to the "profinfo" word of an allocation point. + It's done like this to avoid re-calculating the place in the node + (which already has to be done in the OCaml-generated code run before + this function). */ + node = (value) profinfo_words; + Assert(Alloc_point_profinfo(node, 0) == Val_unit); + + /* The profinfo value is stored shifted to reduce the number of + instructions required on the OCaml side. It also enables us to use + [Infix_tag] to obtain valid value pointers into the middle of nodes, + which is used for the linked list of all allocation points. */ + profinfo = Make_header_with_profinfo( + index_within_node, Infix_tag, Caml_black, profinfo); + + Assert(!Is_block(profinfo)); + Alloc_point_profinfo(node, 0) = profinfo; + /* The count is set to zero by the initialisation when the node was + created (see above). */ + Assert(Alloc_point_count(node, 0) == Val_long(0)); + + /* Add the new allocation point into the linked list of all allocation + points. */ + if (caml_all_allocation_points != NULL) { + Alloc_point_next_ptr(node, 0) = (value) &caml_all_allocation_points->count; + } + else { + Assert(Alloc_point_next_ptr(node, 0) == Val_unit); + } + caml_all_allocation_points = (allocation_point*) node; + + return profinfo; +} + +uintnat caml_spacetime_my_profinfo (struct ext_table** cached_frames, + uintnat wosize) +{ + /* Return the profinfo value that should be written into a value's header + during an allocation from C. This may necessitate extending the trie + with information obtained from libunwind. */ + + c_node* node; + uintnat profinfo = 0; + + node = find_trie_node_from_libunwind(1, wosize, cached_frames); + if (node != NULL) { + profinfo = ((uintnat) (node->data.allocation.profinfo)) >> PROFINFO_SHIFT; + } + + return profinfo; /* N.B. not shifted by PROFINFO_SHIFT */ +} + +void caml_spacetime_automatic_snapshot (void) +{ + if (automatic_snapshots) { + double start_time, end_time; + start_time = caml_sys_time_unboxed(Val_unit); + if (start_time >= next_snapshot_time) { + maybe_reopen_snapshot_channel(); + caml_spacetime_save_snapshot(snapshot_channel, 0.0, 0); + end_time = caml_sys_time_unboxed(Val_unit); + next_snapshot_time = end_time + snapshot_interval; + } + } +} + +CAMLprim value caml_spacetime_save_event_for_automatic_snapshots + (value v_event_name) +{ + if (automatic_snapshots) { + maybe_reopen_snapshot_channel(); + caml_spacetime_save_event_internal (Val_unit, snapshot_channel, + v_event_name); + } + return Val_unit; +} + +void caml_spacetime_automatic_save (void) +{ + /* Called from [atexit]. */ + + if (automatic_snapshots) { + automatic_snapshots = 0; + maybe_reopen_snapshot_channel(); + save_trie(snapshot_channel, 0.0, 0); + caml_flush(snapshot_channel); + caml_close_channel(snapshot_channel); + } +} + +CAMLprim value caml_spacetime_enabled (value v_unit) +{ + return Val_true; +} + +CAMLprim value caml_register_channel_for_spacetime (value v_channel) +{ + struct channel* channel = Channel(v_channel); + channel->flags |= CHANNEL_FLAG_BLOCKING_WRITE; + return Val_unit; +} + +#else + +/* Functions for when the compiler was not configured with "-spacetime". */ + +CAMLprim value caml_spacetime_write_magic_number(value v_channel) +{ + return Val_unit; +} + +CAMLprim value caml_spacetime_enabled (value v_unit) +{ + return Val_false; +} + +CAMLprim value caml_spacetime_save_event (value v_time_opt, + value v_channel, + value v_event_name) +{ + return Val_unit; +} + +CAMLprim value caml_spacetime_save_event_for_automatic_snapshots + (value v_event_name) +{ + return Val_unit; +} + +CAMLprim value caml_spacetime_save_trie (value ignored) +{ + return Val_unit; +} + +CAMLprim value caml_register_channel_for_spacetime (value v_channel) +{ + return Val_unit; +} + +#endif diff --git a/asmrun/spacetime.h b/asmrun/spacetime.h new file mode 100644 index 00000000..bb61bb3c --- /dev/null +++ b/asmrun/spacetime.h @@ -0,0 +1,191 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Mark Shinwell and Leo White, Jane Street Europe */ +/* */ +/* Copyright 2013--2016, Jane Street Group, LLC */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#ifndef CAML_SPACETIME_H +#define CAML_SPACETIME_H + +#include "caml/io.h" +#include "caml/misc.h" +#include "caml/stack.h" + +/* Runtime support for Spacetime profiling. + * This header file is not intended for the casual user. + * + * The implementation is split into three files: + * 1. spacetime.c: core management of the instrumentation; + * 2. spacetime_snapshot.c: the taking of heap snapshots; + * 3. spacetime_offline.c: functions that are also used when examining + * saved profiling data. + */ + +typedef enum { + CALL, + ALLOCATION +} c_node_type; + +/* All pointers between nodes point at the word immediately after the + GC headers, and everything is traversable using the normal OCaml rules. + + On entry to an OCaml function: + If the node hole pointer register has the bottom bit set, then the function + is being tail called or called from a self-recursive call site: + - If the node hole is empty, the callee must create a new node and link + it into the tail chain. The node hole pointer will point at the tail + chain. + - Otherwise the node should be used as normal. + Otherwise (not a tail call): + - If the node hole is empty, the callee must create a new node, but the + tail chain is untouched. + - Otherwise the node should be used as normal. +*/ + +/* Classification of nodes (OCaml or C) with corresponding GC tags. */ +#define OCaml_node_tag 0 +#define C_node_tag 1 +#define Is_ocaml_node(node) (Is_block(node) && Tag_val(node) == OCaml_node_tag) +#define Is_c_node(node) (Is_block(node) && Tag_val(node) == C_node_tag) + +/* The header words are: + 1. The node program counter. + 2. The tail link. */ +#define Node_num_header_words 2 + +/* The "node program counter" at the start of an OCaml node. */ +#define Node_pc(node) (Field(node, 0)) +#define Encode_node_pc(pc) (((value) pc) | 1) +#define Decode_node_pc(encoded_pc) ((void*) (encoded_pc & ~1)) + +/* The circular linked list of tail-called functions within OCaml nodes. */ +#define Tail_link(node) (Field(node, 1)) + +/* The convention for pointers from OCaml nodes to other nodes. There are + two special cases: + 1. [Val_unit] means "uninitialized", and further, that this is not a + tail call point. (Tail call points are pre-initialized, as in case 2.) + 2. If the bottom bit is set, and the value is not [Val_unit], this is a + tail call point. */ +#define Encode_tail_caller_node(node) ((node) | 1) +#define Decode_tail_caller_node(node) ((node) & ~1) +#define Is_tail_caller_node_encoded(node) (((node) & 1) == 1) + +/* Allocation points within OCaml nodes. + The "profinfo" value looks exactly like a black Infix_tag header. + This enables us to point just after it and return such pointer as a valid + OCaml value. (Used for the list of all allocation points. We could do + without this and instead just encode the list pointers as integers, but + this would mean that the structure was destroyed on marshalling. This + might not be a great problem since it is intended that the total counts + be obtained via snapshots, but it seems neater and easier to use + Infix_tag. + The "count" is just an OCaml integer giving the total number of words + (including headers) allocated at the point. + The "pointer to next allocation point" points to the "count" word of the + next allocation point in the linked list of all allocation points. + There is no special encoding needed by virtue of the [Infix_tag] trick. */ +#define Alloc_point_profinfo(node, offset) (Field(node, offset)) +#define Alloc_point_count(node, offset) (Field(node, offset + 1)) +#define Alloc_point_next_ptr(node, offset) (Field(node, offset + 2)) + +/* Direct call points (tail or non-tail) within OCaml nodes. + They just hold a pointer to the child node. The call site and callee are + both recorded in the shape. */ +#define Direct_callee_node(node,offset) (Field(node, offset)) +#define Encode_call_point_pc(pc) (((value) pc) | 1) +#define Decode_call_point_pc(pc) ((void*) (((value) pc) & ~((uintnat) 1))) + +/* Indirect call points (tail or non-tail) within OCaml nodes. + They hold a linked list of (PC upon entry to the callee, pointer to + child node) pairs. The linked list is encoded using C nodes and should + be thought of as part of the OCaml node itself. */ +#define Indirect_num_fields 1 +#define Indirect_pc_linked_list(node,offset) (Field(node, offset)) + +/* Encodings of the program counter value within a C node. */ +#define Encode_c_node_pc_for_call(pc) ((((value) pc) << 2) | 3) +#define Encode_c_node_pc_for_alloc_point(pc) ((((value) pc) << 2) | 1) +#define Decode_c_node_pc(pc) ((void*) (((uintnat) (pc)) >> 2)) + +typedef struct { + /* The layout and encoding of this structure must match that of the + allocation points within OCaml nodes, so that the linked list + traversal across all allocation points works correctly. */ + value profinfo; /* encoded using [Infix_tag] (see above) */ + value count; + /* [next] is [Val_unit] for the end of the list. + Otherwise it points at the second word of this [allocation_point] + structure. */ + value next; +} allocation_point; + +typedef struct { + /* CR-soon mshinwell: delete [gc_header], all the offset arithmetic will + then go away */ + uintnat gc_header; + uintnat pc; /* see above for encodings */ + union { + value callee_node; /* for CALL */ + allocation_point allocation; /* for ALLOCATION */ + } data; + value next; /* [Val_unit] for the end of the list */ +} c_node; /* CR-soon mshinwell: rename to dynamic_node */ + +typedef struct shape_table { + uint64_t* table; + struct shape_table* next; +} shape_table; + +extern uint64_t** caml_spacetime_static_shape_tables; +extern shape_table* caml_spacetime_dynamic_shape_tables; + +typedef struct ext_table* spacetime_unwind_info_cache; + +extern value caml_spacetime_trie_root; +extern value* caml_spacetime_trie_node_ptr; +extern value* caml_spacetime_finaliser_trie_root; + +extern allocation_point* caml_all_allocation_points; + +extern void caml_spacetime_initialize(void); +extern uintnat caml_spacetime_my_profinfo( + spacetime_unwind_info_cache*, uintnat); +extern c_node_type caml_spacetime_classify_c_node(c_node* node); +extern c_node* caml_spacetime_c_node_of_stored_pointer(value); +extern c_node* caml_spacetime_c_node_of_stored_pointer_not_null(value); +extern value caml_spacetime_stored_pointer_of_c_node(c_node* node); +extern void caml_spacetime_register_thread(value*, value*); +extern void caml_spacetime_register_shapes(void*); +extern value caml_spacetime_frame_table(void); +extern value caml_spacetime_shape_table(void); +extern void caml_spacetime_save_snapshot (struct channel *chan, + double time_override, + int use_time_override); +extern value caml_spacetime_timestamp(double time_override, + int use_time_override); +extern void caml_spacetime_automatic_snapshot (void); + +/* For use in runtime functions that are executed from OCaml + code, to save the overhead of using libunwind every time. */ +#ifdef WITH_SPACETIME +#define Get_my_profinfo_with_cached_backtrace(profinfo, size) \ + do { \ + static spacetime_unwind_info_cache spacetime_unwind_info = NULL; \ + profinfo = caml_spacetime_my_profinfo(&spacetime_unwind_info, size); \ + } \ + while (0); +#else +#define Get_my_profinfo_with_cached_backtrace(profinfo, size) \ + profinfo = (uintnat) 0; +#endif + +#endif diff --git a/asmrun/spacetime_offline.c b/asmrun/spacetime_offline.c new file mode 100644 index 00000000..221c6a66 --- /dev/null +++ b/asmrun/spacetime_offline.c @@ -0,0 +1,228 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Mark Shinwell and Leo White, Jane Street Europe */ +/* */ +/* Copyright 2013--2016, Jane Street Group, LLC */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS + +#include +#include +#include +#include +#include + +#include "caml/alloc.h" +#include "caml/config.h" +#include "caml/fail.h" +#include "caml/gc.h" +#include "caml/intext.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/roots.h" +#include "caml/signals.h" +#include "caml/stack.h" +#include "caml/sys.h" +#include "spacetime.h" + +#include "../config/s.h" + +#ifdef ARCH_SIXTYFOUR + +/* CR-someday lwhite: The following two definitions are copied from spacetime.c + because they are needed here, but must be inlined in spacetime.c + for performance. Perhaps a macro or "static inline" would be + more appropriate. */ + +c_node* caml_spacetime_offline_c_node_of_stored_pointer_not_null + (value node_stored) +{ + Assert(Is_c_node(node_stored)); + return (c_node*) Hp_val(node_stored); +} + +c_node_type caml_spacetime_offline_classify_c_node(c_node* node) +{ + return (node->pc & 2) ? CALL : ALLOCATION; +} + +CAMLprim value caml_spacetime_compare_node( + value node1, value node2) +{ + Assert(!Is_in_value_area(node1)); + Assert(!Is_in_value_area(node2)); + + if (node1 == node2) { + return Val_long(0); + } + if (node1 < node2) { + return Val_long(-1); + } + return Val_long(1); +} + +CAMLprim value caml_spacetime_unmarshal_trie (value v_channel) +{ + return caml_input_value_to_outside_heap(v_channel); +} + +CAMLprim value caml_spacetime_node_num_header_words(value unit) +{ + unit = Val_unit; + return Val_long(Node_num_header_words); +} + +CAMLprim value caml_spacetime_is_ocaml_node(value node) +{ + Assert(Is_ocaml_node(node) || Is_c_node(node)); + return Val_bool(Is_ocaml_node(node)); +} + +CAMLprim value caml_spacetime_ocaml_function_identifier(value node) +{ + Assert(Is_ocaml_node(node)); + return caml_copy_int64((uint64_t) Decode_node_pc(Node_pc(node))); +} + +CAMLprim value caml_spacetime_ocaml_tail_chain(value node) +{ + Assert(Is_ocaml_node(node)); + return Tail_link(node); +} + +CAMLprim value caml_spacetime_classify_direct_call_point + (value node, value offset) +{ + uintnat field; + value callee_node; + + Assert(Is_ocaml_node(node)); + + field = Long_val(offset); + + callee_node = Direct_callee_node(node, field); + if (!Is_block(callee_node)) { + /* An unused call point (may be a tail call point). */ + return Val_long(0); + } else if (Is_ocaml_node(callee_node)) { + return Val_long(1); /* direct call point to OCaml code */ + } else { + return Val_long(2); /* direct call point to non-OCaml code */ + } +} + +CAMLprim value caml_spacetime_ocaml_allocation_point_annotation + (value node, value offset) +{ + uintnat profinfo_shifted; + profinfo_shifted = (uintnat) Alloc_point_profinfo(node, Long_val(offset)); + return Val_long(Profinfo_hd(profinfo_shifted)); +} + +CAMLprim value caml_spacetime_ocaml_allocation_point_count + (value node, value offset) +{ + value count = Alloc_point_count(node, Long_val(offset)); + Assert(!Is_block(count)); + return count; +} + +CAMLprim value caml_spacetime_ocaml_direct_call_point_callee_node + (value node, value offset) +{ + return Direct_callee_node(node, Long_val(offset)); +} + +CAMLprim value caml_spacetime_ocaml_indirect_call_point_callees + (value node, value offset) +{ + value callees = Indirect_pc_linked_list(node, Long_val(offset)); + Assert(Is_block(callees)); + Assert(Is_c_node(callees)); + return callees; +} + +CAMLprim value caml_spacetime_c_node_is_call(value node) +{ + c_node* c_node; + Assert(node != (value) NULL); + Assert(Is_c_node(node)); + c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node); + switch (caml_spacetime_offline_classify_c_node(c_node)) { + case CALL: return Val_true; + case ALLOCATION: return Val_false; + } + Assert(0); + return Val_unit; /* silence compiler warning */ +} + +CAMLprim value caml_spacetime_c_node_next(value node) +{ + c_node* c_node; + + Assert(node != (value) NULL); + Assert(Is_c_node(node)); + c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node); + Assert(c_node->next == Val_unit || Is_c_node(c_node->next)); + return c_node->next; +} + +CAMLprim value caml_spacetime_c_node_call_site(value node) +{ + c_node* c_node; + Assert(node != (value) NULL); + Assert(Is_c_node(node)); + c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node); + return caml_copy_int64((uint64_t) Decode_c_node_pc(c_node->pc)); +} + +CAMLprim value caml_spacetime_c_node_callee_node(value node) +{ + c_node* c_node; + Assert(node != (value) NULL); + Assert(Is_c_node(node)); + c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node); + Assert(caml_spacetime_offline_classify_c_node(c_node) == CALL); + /* This might be an uninitialised tail call point: for example if an OCaml + callee was indirectly called but the callee wasn't instrumented (e.g. a + leaf function that doesn't allocate). */ + if (Is_tail_caller_node_encoded(c_node->data.callee_node)) { + return Val_unit; + } + return c_node->data.callee_node; +} + +CAMLprim value caml_spacetime_c_node_profinfo(value node) +{ + c_node* c_node; + Assert(node != (value) NULL); + Assert(Is_c_node(node)); + c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node); + Assert(caml_spacetime_offline_classify_c_node(c_node) == ALLOCATION); + Assert(!Is_block(c_node->data.allocation.profinfo)); + return Val_long(Profinfo_hd(c_node->data.allocation.profinfo)); +} + +CAMLprim value caml_spacetime_c_node_allocation_count(value node) +{ + c_node* c_node; + Assert(node != (value) NULL); + Assert(Is_c_node(node)); + c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node); + Assert(caml_spacetime_offline_classify_c_node(c_node) == ALLOCATION); + Assert(!Is_block(c_node->data.allocation.count)); + return c_node->data.allocation.count; +} + +#endif diff --git a/asmrun/spacetime_snapshot.c b/asmrun/spacetime_snapshot.c new file mode 100644 index 00000000..9c582a83 --- /dev/null +++ b/asmrun/spacetime_snapshot.c @@ -0,0 +1,600 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Mark Shinwell and Leo White, Jane Street Europe */ +/* */ +/* Copyright 2013--2016, Jane Street Group, LLC */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS + +#include +#include +#include +#include +#include + +#include "caml/alloc.h" +#include "caml/backtrace_prim.h" +#include "caml/config.h" +#include "caml/custom.h" +#include "caml/fail.h" +#include "caml/gc.h" +#include "caml/gc_ctrl.h" +#include "caml/intext.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/roots.h" +#include "caml/signals.h" +#include "caml/stack.h" +#include "caml/sys.h" +#include "spacetime.h" + +#ifdef WITH_SPACETIME + +/* The following structures must match the type definitions in the + [Spacetime] module. */ + +typedef struct { + /* (GC header here.) */ + value minor_words; + value promoted_words; + value major_words; + value minor_collections; + value major_collections; + value heap_words; + value heap_chunks; + value compactions; + value top_heap_words; +} gc_stats; + +typedef struct { + value profinfo; + value num_blocks; + value num_words_including_headers; +} snapshot_entry; + +typedef struct { + /* (GC header here.) */ + snapshot_entry entries[0]; +} snapshot_entries; + +typedef struct { + /* (GC header here.) */ + value time; + value gc_stats; + value entries; + value words_scanned; + value words_scanned_with_profinfo; + value total_allocations; +} snapshot; + +typedef struct { + uintnat num_blocks; + uintnat num_words_including_headers; +} raw_snapshot_entry; + +static value allocate_outside_heap_with_tag(mlsize_t size_in_bytes, tag_t tag) +{ + /* CR-soon mshinwell: this function should live somewhere else */ + header_t* block; + + Assert(size_in_bytes % sizeof(value) == 0); + block = caml_stat_alloc(sizeof(header_t) + size_in_bytes); + *block = Make_header(size_in_bytes / sizeof(value), tag, Caml_black); + return (value) &block[1]; +} + +static value allocate_outside_heap(mlsize_t size_in_bytes) +{ + Assert(size_in_bytes > 0); + return allocate_outside_heap_with_tag(size_in_bytes, 0); +} + +static value take_gc_stats(void) +{ + value v_stats; + gc_stats* stats; + + v_stats = allocate_outside_heap(sizeof(gc_stats)); + stats = (gc_stats*) v_stats; + + stats->minor_words = Val_long(caml_stat_minor_words); + stats->promoted_words = Val_long(caml_stat_promoted_words); + stats->major_words = + Val_long(((uintnat) caml_stat_major_words) + + ((uintnat) caml_allocated_words)); + stats->minor_collections = Val_long(caml_stat_minor_collections); + stats->major_collections = Val_long(caml_stat_major_collections); + stats->heap_words = Val_long(caml_stat_heap_wsz / sizeof(value)); + stats->heap_chunks = Val_long(caml_stat_heap_chunks); + stats->compactions = Val_long(caml_stat_compactions); + stats->top_heap_words = Val_long(caml_stat_top_heap_wsz / sizeof(value)); + + return v_stats; +} + +static value get_total_allocations(void) +{ + value v_total_allocations = Val_unit; + allocation_point* total = caml_all_allocation_points; + + while (total != NULL) { + value v_total; + v_total = allocate_outside_heap_with_tag(3 * sizeof(value), 0); + + /* [v_total] is of type [Raw_spacetime_lib.total_allocations]. */ + Field(v_total, 0) = Val_long(Profinfo_hd(total->profinfo)); + Field(v_total, 1) = total->count; + Field(v_total, 2) = v_total_allocations; + v_total_allocations = v_total; + + Assert (total->next == Val_unit + || (Is_block(total->next) && Tag_val(total->next) == Infix_tag)); + if (total->next == Val_unit) { + total = NULL; + } + else { + total = (allocation_point*) Hp_val(total->next); + } + } + + return v_total_allocations; +} + +static value take_snapshot(double time_override, int use_time_override) +{ + value v_snapshot; + snapshot* heap_snapshot; + value v_entries; + snapshot_entries* entries; + char* chunk; + value gc_stats; + uintnat index; + uintnat target_index; + value v_time; + double time; + uintnat profinfo; + uintnat num_distinct_profinfos; + /* Fixed size buffer to avoid needing a hash table: */ + static raw_snapshot_entry* raw_entries = NULL; + uintnat words_scanned = 0; + uintnat words_scanned_with_profinfo = 0; + value v_total_allocations; + + if (!use_time_override) { + time = caml_sys_time_unboxed(Val_unit); + } + else { + time = time_override; + } + + gc_stats = take_gc_stats(); + + if (raw_entries == NULL) { + size_t size = (PROFINFO_MASK + 1) * sizeof(raw_snapshot_entry); + raw_entries = caml_stat_alloc(size); + memset(raw_entries, '\0', size); + } else { + size_t size = (PROFINFO_MASK + 1) * sizeof(raw_snapshot_entry); + memset(raw_entries, '\0', size); + } + + num_distinct_profinfos = 0; + + /* CR-someday mshinwell: consider reintroducing minor heap scanning, + properly from roots, which would then give a snapshot function + that doesn't do a minor GC. Although this may not be that important + and potentially not worth the effort (it's quite tricky). */ + + /* Scan the major heap. */ + chunk = caml_heap_start; + while (chunk != NULL) { + char* hp; + char* limit; + + hp = chunk; + limit = chunk + Chunk_size (chunk); + + while (hp < limit) { + header_t hd = Hd_hp (hp); + switch (Color_hd(hd)) { + case Caml_blue: + break; + + default: + if (Wosize_hd(hd) > 0) { /* ignore atoms */ + profinfo = Profinfo_hd(hd); + words_scanned += Whsize_hd(hd); + if (profinfo > 0 && profinfo < PROFINFO_MASK) { + words_scanned_with_profinfo += Whsize_hd(hd); + Assert (raw_entries[profinfo].num_blocks >= 0); + if (raw_entries[profinfo].num_blocks == 0) { + num_distinct_profinfos++; + } + raw_entries[profinfo].num_blocks++; + raw_entries[profinfo].num_words_including_headers += + Whsize_hd(hd); + } + } + break; + } + hp += Bhsize_hd (hd); + Assert (hp <= limit); + } + + chunk = Chunk_next (chunk); + } + + if (num_distinct_profinfos > 0) { + v_entries = allocate_outside_heap( + num_distinct_profinfos*sizeof(snapshot_entry)); + entries = (snapshot_entries*) v_entries; + target_index = 0; + for (index = 0; index <= PROFINFO_MASK; index++) { + Assert(raw_entries[index].num_blocks >= 0); + if (raw_entries[index].num_blocks > 0) { + Assert(target_index < num_distinct_profinfos); + entries->entries[target_index].profinfo = Val_long(index); + entries->entries[target_index].num_blocks + = Val_long(raw_entries[index].num_blocks); + entries->entries[target_index].num_words_including_headers + = Val_long(raw_entries[index].num_words_including_headers); + target_index++; + } + } + } else { + v_entries = Atom(0); + } + + Assert(sizeof(double) == sizeof(value)); + v_time = allocate_outside_heap_with_tag(sizeof(double), Double_tag); + Double_field(v_time, 0) = time; + + v_snapshot = allocate_outside_heap(sizeof(snapshot)); + heap_snapshot = (snapshot*) v_snapshot; + + v_total_allocations = get_total_allocations(); + + heap_snapshot->time = v_time; + heap_snapshot->gc_stats = gc_stats; + heap_snapshot->entries = v_entries; + heap_snapshot->words_scanned + = Val_long(words_scanned); + heap_snapshot->words_scanned_with_profinfo + = Val_long(words_scanned_with_profinfo); + heap_snapshot->total_allocations = v_total_allocations; + + return v_snapshot; +} + +void caml_spacetime_save_snapshot (struct channel *chan, double time_override, + int use_time_override) +{ + value v_snapshot; + value v_total_allocations; + snapshot* heap_snapshot; + + Lock(chan); + + v_snapshot = take_snapshot(time_override, use_time_override); + + caml_output_val(chan, Val_long(0), Val_long(0)); + + caml_extern_allow_out_of_heap = 1; + caml_output_val(chan, v_snapshot, Val_long(0)); + caml_extern_allow_out_of_heap = 0; + + Unlock(chan); + + heap_snapshot = (snapshot*) v_snapshot; + caml_stat_free(Hp_val(heap_snapshot->time)); + caml_stat_free(Hp_val(heap_snapshot->gc_stats)); + if (Wosize_val(heap_snapshot->entries) > 0) { + caml_stat_free(Hp_val(heap_snapshot->entries)); + } + v_total_allocations = heap_snapshot->total_allocations; + while (v_total_allocations != Val_unit) { + value next = Field(v_total_allocations, 2); + caml_stat_free(Hp_val(v_total_allocations)); + v_total_allocations = next; + } + + caml_stat_free(Hp_val(v_snapshot)); +} + +CAMLprim value caml_spacetime_take_snapshot(value v_time_opt, value v_channel) +{ + struct channel * channel = Channel(v_channel); + double time_override = 0.0; + int use_time_override = 0; + + if (Is_block(v_time_opt)) { + time_override = Double_field(Field(v_time_opt, 0), 0); + use_time_override = 1; + } + + caml_spacetime_save_snapshot(channel, time_override, use_time_override); + + return Val_unit; +} + +extern struct custom_operations caml_int64_ops; /* ints.c */ + +static value +allocate_int64_outside_heap(uint64_t i) +{ + value v; + + v = allocate_outside_heap_with_tag(2 * sizeof(value), Custom_tag); + Custom_ops_val(v) = &caml_int64_ops; + Int64_val(v) = i; + + return v; +} + +static value +copy_string_outside_heap(char const *s) +{ + int len; + mlsize_t wosize, offset_index; + value result; + + len = strlen(s); + wosize = (len + sizeof (value)) / sizeof (value); + result = allocate_outside_heap_with_tag(wosize * sizeof(value), String_tag); + + Field (result, wosize - 1) = 0; + offset_index = Bsize_wsize (wosize) - 1; + Byte (result, offset_index) = offset_index - len; + memmove(String_val(result), s, len); + + return result; +} + +static value +allocate_loc_outside_heap(struct caml_loc_info li) +{ + value result; + + if (li.loc_valid) { + result = allocate_outside_heap_with_tag(5 * sizeof(value), 0); + Field(result, 0) = Val_bool(li.loc_is_raise); + Field(result, 1) = copy_string_outside_heap(li.loc_filename); + Field(result, 2) = Val_int(li.loc_lnum); + Field(result, 3) = Val_int(li.loc_startchr); + Field(result, 4) = Val_int(li.loc_endchr); + } else { + result = allocate_outside_heap_with_tag(sizeof(value), 1); + Field(result, 0) = Val_bool(li.loc_is_raise); + } + + return result; +} + +value caml_spacetime_timestamp(double time_override, int use_time_override) +{ + double time; + value v_time; + + if (!use_time_override) { + time = caml_sys_time_unboxed(Val_unit); + } + else { + time = time_override; + } + + v_time = allocate_outside_heap_with_tag(sizeof(double), Double_tag); + Double_field(v_time, 0) = time; + + return v_time; +} + +value caml_spacetime_frame_table(void) +{ + /* Flatten the frame table into a single associative list. */ + + value list = Val_long(0); /* the empty list */ + uintnat i; + + if (!caml_debug_info_available()) { + return list; + } + + if (caml_frame_descriptors == NULL) { + caml_init_frame_descriptors(); + } + + for (i = 0; i <= caml_frame_descriptors_mask; i++) { + frame_descr* descr = caml_frame_descriptors[i]; + if (descr != NULL) { + value location, return_address, pair, new_list_element, location_list; + struct caml_loc_info li; + debuginfo dbg; + if (descr->frame_size != 0xffff) { + dbg = caml_debuginfo_extract(descr); + if (dbg != NULL) { + location_list = Val_unit; + while (dbg != NULL) { + value list_element; + + caml_debuginfo_location(dbg, &li); + location = allocate_loc_outside_heap(li); + + list_element = + allocate_outside_heap_with_tag(2 * sizeof(value), 0 /* (::) */); + Field(list_element, 0) = location; + Field(list_element, 1) = location_list; + location_list = list_element; + + dbg = caml_debuginfo_next(dbg); + } + + return_address = allocate_int64_outside_heap(descr->retaddr); + pair = allocate_outside_heap_with_tag(2 * sizeof(value), 0); + Field(pair, 0) = return_address; + Field(pair, 1) = location_list; + + new_list_element = + allocate_outside_heap_with_tag(2 * sizeof(value), 0 /* (::) */); + Field(new_list_element, 0) = pair; + Field(new_list_element, 1) = list; + list = new_list_element; + } + } + } + } + + return list; +} + +static void add_unit_to_shape_table(uint64_t *unit_table, value *list) +{ + /* This function reverses the order of the lists giving the layout of each + node; however, spacetime_profiling.ml ensures they are emitted in + reverse order, so at the end of it all they're not reversed. */ + + uint64_t* ptr = unit_table; + + while (*ptr != (uint64_t) 0) { + value new_list_element, pair, function_address, layout; + + function_address = + allocate_int64_outside_heap(*ptr++); + + layout = Val_long(0); /* the empty list */ + while (*ptr != (uint64_t) 0) { + int tag; + int stored_tag; + value part_of_shape; + value new_part_list_element; + value location; + int has_extra_argument = 0; + + stored_tag = *ptr++; + /* CR-soon mshinwell: share with emit.mlp */ + switch (stored_tag) { + case 1: /* direct call to given location */ + tag = 0; + has_extra_argument = 1; /* the address of the callee */ + break; + + case 2: /* indirect call to given location */ + tag = 1; + break; + + case 3: /* allocation at given location */ + tag = 2; + break; + + default: + Assert(0); + abort(); /* silence compiler warning */ + } + + location = allocate_int64_outside_heap(*ptr++); + + part_of_shape = allocate_outside_heap_with_tag( + sizeof(value) * (has_extra_argument ? 2 : 1), tag); + Field(part_of_shape, 0) = location; + if (has_extra_argument) { + Field(part_of_shape, 1) = + allocate_int64_outside_heap(*ptr++); + } + + new_part_list_element = + allocate_outside_heap_with_tag(2 * sizeof(value), 0 /* (::) */); + Field(new_part_list_element, 0) = part_of_shape; + Field(new_part_list_element, 1) = layout; + layout = new_part_list_element; + } + + pair = allocate_outside_heap_with_tag(2 * sizeof(value), 0); + Field(pair, 0) = function_address; + Field(pair, 1) = layout; + + new_list_element = + allocate_outside_heap_with_tag(2 * sizeof(value), 0 /* (::) */); + Field(new_list_element, 0) = pair; + Field(new_list_element, 1) = *list; + *list = new_list_element; + + ptr++; + } +} + +value caml_spacetime_shape_table(void) +{ + value list; + uint64_t* unit_table; + shape_table *dynamic_table; + uint64_t** static_table; + + /* Flatten the hierarchy of shape tables into a single associative list + mapping from function symbols to node layouts. The node layouts are + themselves lists. */ + + list = Val_long(0); /* the empty list */ + + /* Add static shape tables */ + static_table = caml_spacetime_static_shape_tables; + while (*static_table != (uint64_t) 0) { + unit_table = *static_table++; + add_unit_to_shape_table(unit_table, &list); + } + + /* Add dynamic shape tables */ + dynamic_table = caml_spacetime_dynamic_shape_tables; + + while (dynamic_table != NULL) { + unit_table = dynamic_table->table; + add_unit_to_shape_table(unit_table, &list); + dynamic_table = dynamic_table->next; + } + + return list; +} + +#else + +static value spacetime_disabled() +{ + caml_failwith("Spacetime profiling not enabled"); + Assert(0); /* unreachable */ +} + +CAMLprim value caml_spacetime_take_snapshot(value ignored) +{ + return Val_unit; +} + +CAMLprim value caml_spacetime_marshal_frame_table () +{ + return spacetime_disabled(); +} + +CAMLprim value caml_spacetime_frame_table () +{ + return spacetime_disabled(); +} + +CAMLprim value caml_spacetime_marshal_shape_table () +{ + return spacetime_disabled(); +} + +CAMLprim value caml_spacetime_shape_table () +{ + return spacetime_disabled(); +} + +#endif diff --git a/asmrun/stack.h b/asmrun/stack.h deleted file mode 100644 index 8556b336..00000000 --- a/asmrun/stack.h +++ /dev/null @@ -1,119 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -/* Machine-dependent interface with the asm code */ - -#ifndef CAML_STACK_H -#define CAML_STACK_H - -/* Macros to access the stack frame */ - -#ifdef TARGET_sparc -#define Saved_return_address(sp) *((intnat *)((sp) + 92)) -#define Callback_link(sp) ((struct caml_context *)((sp) + 104)) -#endif - -#ifdef TARGET_i386 -#define Saved_return_address(sp) *((intnat *)((sp) - 4)) -#ifndef SYS_win32 -#define Callback_link(sp) ((struct caml_context *)((sp) + 16)) -#else -#define Callback_link(sp) ((struct caml_context *)((sp) + 8)) -#endif -#endif - -#ifdef TARGET_power -#if defined(MODEL_ppc) -#define Saved_return_address(sp) *((intnat *)((sp) - 4)) -#define Callback_link(sp) ((struct caml_context *)((sp) + 16)) -#elif defined(MODEL_ppc64) -#define Saved_return_address(sp) *((intnat *)((sp) + 16)) -#define Callback_link(sp) ((struct caml_context *)((sp) + (48 + 32))) -#elif defined(MODEL_ppc64le) -#define Saved_return_address(sp) *((intnat *)((sp) + 16)) -#define Callback_link(sp) ((struct caml_context *)((sp) + (32 + 32))) -#else -#error "TARGET_power: wrong MODEL" -#endif -#define Already_scanned(sp, retaddr) ((retaddr) & 1) -#define Mask_already_scanned(retaddr) ((retaddr) & ~1) -#define Mark_scanned(sp, retaddr) Saved_return_address(sp) = (retaddr) | 1 -#endif - -#ifdef TARGET_s390x -#define Saved_return_address(sp) *((intnat *)((sp) - SIZEOF_PTR)) -#define Trap_frame_size 16 -#define Callback_link(sp) ((struct caml_context *)((sp) + Trap_frame_size)) -#endif - -#ifdef TARGET_arm -#define Saved_return_address(sp) *((intnat *)((sp) - 4)) -#define Callback_link(sp) ((struct caml_context *)((sp) + 8)) -#endif - -#ifdef TARGET_amd64 -#define Saved_return_address(sp) *((intnat *)((sp) - 8)) -#define Callback_link(sp) ((struct caml_context *)((sp) + 16)) -#endif - -#ifdef TARGET_arm64 -#define Saved_return_address(sp) *((intnat *)((sp) - 8)) -#define Callback_link(sp) ((struct caml_context *)((sp) + 16)) -#endif - -/* Structure of OCaml callback contexts */ - -struct caml_context { - char * bottom_of_stack; /* beginning of OCaml stack chunk */ - uintnat last_retaddr; /* last return address in OCaml code */ - value * gc_regs; /* pointer to register block */ -}; - -/* Structure of frame descriptors */ - -typedef struct { - uintnat retaddr; - unsigned short frame_size; - unsigned short num_live; - unsigned short live_ofs[1]; -} frame_descr; - -/* Hash table of frame descriptors */ - -extern frame_descr ** caml_frame_descriptors; -extern int caml_frame_descriptors_mask; - -#define Hash_retaddr(addr) \ - (((uintnat)(addr) >> 3) & caml_frame_descriptors_mask) - -extern void caml_init_frame_descriptors(void); -extern void caml_register_frametable(intnat *); -extern void caml_unregister_frametable(intnat *); -extern void caml_register_dyn_global(void *); - -extern uintnat caml_stack_usage (void); -extern uintnat (*caml_stack_usage_hook)(void); - -/* Declaration of variables used in the asm code */ -extern char * caml_top_of_stack; -extern char * caml_bottom_of_stack; -extern uintnat caml_last_return_address; -extern value * caml_gc_regs; -extern char * caml_exception_pointer; -extern value * caml_globals[]; -extern intnat caml_globals_inited; -extern intnat * caml_frametable[]; - -#endif /* CAML_STACK_H */ diff --git a/asmrun/startup.c b/asmrun/startup.c index da61ffcd..ccf87d02 100644 --- a/asmrun/startup.c +++ b/asmrun/startup.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Start-up code */ #include @@ -31,9 +33,12 @@ #include "caml/mlvalues.h" #include "caml/osdeps.h" #include "caml/printexc.h" -#include "stack.h" +#include "caml/stack.h" #include "caml/startup_aux.h" #include "caml/sys.h" +#ifdef WITH_SPACETIME +#include "spacetime.h" +#endif #ifdef HAS_UI #include "caml/ui.h" #endif @@ -88,14 +93,13 @@ extern value caml_start_program (void); extern void caml_init_ieee_floats (void); extern void caml_init_signals (void); -#ifdef _MSC_VER +#if defined(_MSC_VER) && __STDC_SECURE_LIB__ >= 200411L /* PR 4887: avoid crash box of windows runtime on some system calls */ extern void caml_install_invalid_parameter_handler(); #endif - void caml_main(char **argv) { char * exe_name; @@ -103,9 +107,12 @@ void caml_main(char **argv) value res; char tos; +#ifdef WITH_SPACETIME + caml_spacetime_initialize(); +#endif caml_init_frame_descriptors(); caml_init_ieee_floats(); -#ifdef _MSC_VER +#if defined(_MSC_VER) && __STDC_SECURE_LIB__ >= 200411L caml_install_invalid_parameter_handler(); #endif caml_init_custom_operations(); diff --git a/boot/ocamlc b/boot/ocamlc index 6ec07c9e..0c31cda0 100755 Binary files a/boot/ocamlc and b/boot/ocamlc differ diff --git a/boot/ocamldep b/boot/ocamldep index ea6697cc..eacfcf04 100755 Binary files a/boot/ocamldep and b/boot/ocamldep differ diff --git a/boot/ocamllex b/boot/ocamllex index 78a36bd7..0e9b1b4c 100755 Binary files a/boot/ocamllex and b/boot/ocamllex differ diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 806c22cb..79384c1f 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -136,38 +136,41 @@ type rhs_kind = let rec check_recordwith_updates id e = match e with - | Lsequence (Lprim ((Psetfield _ | Psetfloatfield _), [Lvar id2; _]), cont) + | Lsequence (Lprim ((Psetfield _ | Psetfloatfield _), [Lvar id2; _], _), cont) -> id2 = id && check_recordwith_updates id cont | Lvar id2 -> id2 = id | _ -> false ;; let rec size_of_lambda = function - | Lfunction{kind; params; body} as funct -> + | Lfunction{params} as funct -> RHS_function (1 + IdentSet.cardinal(free_variables funct), List.length params) - | Llet (Strict, id, Lprim (Pduprecord (kind, size), _), body) + | Llet (Strict, _k, id, Lprim (Pduprecord (kind, size), _, _), body) when check_recordwith_updates id body -> begin match kind with | Record_regular | Record_inlined _ -> RHS_block size + | Record_unboxed _ -> assert false | Record_float -> RHS_floatblock size | Record_extension -> RHS_block (size + 1) end - | 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) -> + | Llet(_str, _k, _id, _arg, body) -> size_of_lambda body + | Lletrec(_bindings, body) -> size_of_lambda body + | Lprim(Pmakeblock _, args, _) -> RHS_block (List.length args) + | Lprim (Pmakearray ((Paddrarray|Pintarray), _), args, _) -> RHS_block (List.length args) - | Lprim (Pmakearray (Pfloatarray, _), args) -> + | Lprim (Pmakearray (Pfloatarray, _), args, _) -> RHS_floatblock (List.length args) - | Lprim (Pmakearray (Pgenarray, _), args) -> assert false - | Lprim (Pduprecord ((Record_regular | Record_inlined _), size), args) -> + | Lprim (Pmakearray (Pgenarray, _), _, _) -> assert false + | Lprim (Pduprecord ((Record_regular | Record_inlined _), size), _, _) -> RHS_block size - | Lprim (Pduprecord (Record_extension, size), args) -> + | Lprim (Pduprecord (Record_unboxed _, _), _, _) -> + assert false + | Lprim (Pduprecord (Record_extension, size), _, _) -> RHS_block (size + 1) - | Lprim (Pduprecord (Record_float, size), args) -> RHS_floatblock size + | Lprim (Pduprecord (Record_float, size), _, _) -> RHS_floatblock size | Levent (lam, _) -> size_of_lambda lam - | Lsequence (lam, lam') -> size_of_lambda lam' + | Lsequence (_lam, lam') -> size_of_lambda lam' | _ -> RHS_nonrec (**** Merging consecutive events ****) @@ -310,9 +313,9 @@ let comp_primitive p args = Pgetglobal id -> Kgetglobal id | Psetglobal id -> Ksetglobal id | Pintcomp cmp -> Kintcomp cmp - | Pmakeblock(tag, mut) -> Kmakeblock(List.length args, tag) + | Pmakeblock(tag, _mut, _) -> Kmakeblock(List.length args, tag) | Pfield n -> Kgetfield n - | Psetfield(n, ptr, _init) -> Ksetfield n + | Psetfield(n, _ptr, _init) -> Ksetfield n | Pfloatfield n -> Kgetfloatfield n | Psetfloatfield (n, _init) -> Ksetfloatfield n | Pduprecord _ -> Kccall("caml_obj_dup", 1) @@ -321,8 +324,8 @@ let comp_primitive p args = | Paddint -> Kaddint | Psubint -> Ksubint | Pmulint -> Kmulint - | Pdivint -> Kdivint - | Pmodint -> Kmodint + | Pdivint _ -> Kdivint + | Pmodint _ -> Kmodint | Pandint -> Kandint | Porint -> Korint | Pxorint -> Kxorint @@ -346,17 +349,19 @@ let comp_primitive p args = | Pfloatcomp Cle -> Kccall("caml_le_float", 2) | Pfloatcomp Cge -> Kccall("caml_ge_float", 2) | Pstringlength -> Kccall("caml_ml_string_length", 1) + | Pbyteslength -> Kccall("caml_ml_bytes_length", 1) | Pstringrefs -> Kccall("caml_string_get", 2) - | Pstringsets -> Kccall("caml_string_set", 3) - | Pstringrefu -> Kgetstringchar - | Pstringsetu -> Ksetstringchar + | Pbytesrefs -> Kccall("caml_bytes_get", 2) + | Pbytessets -> Kccall("caml_bytes_set", 3) + | Pstringrefu | Pbytesrefu -> Kgetstringchar + | Pbytessetu -> Ksetstringchar | Pstring_load_16(_) -> Kccall("caml_string_get16", 2) | Pstring_load_32(_) -> Kccall("caml_string_get32", 2) | Pstring_load_64(_) -> Kccall("caml_string_get64", 2) | Pstring_set_16(_) -> Kccall("caml_string_set16", 3) | Pstring_set_32(_) -> Kccall("caml_string_set32", 3) | Pstring_set_64(_) -> Kccall("caml_string_set64", 3) - | Parraylength kind -> Kvectlength + | Parraylength _ -> Kvectlength | Parrayrefs Pgenarray -> Kccall("caml_array_get", 2) | Parrayrefs Pfloatarray -> Kccall("caml_array_get_float", 2) | Parrayrefs _ -> Kccall("caml_array_get_addr", 2) @@ -377,7 +382,8 @@ let comp_primitive p args = | Max_wosize -> "max_wosize" | Ostype_unix -> "ostype_unix" | Ostype_win32 -> "ostype_win32" - | Ostype_cygwin -> "ostype_cygwin" in + | Ostype_cygwin -> "ostype_cygwin" + | Backend_type -> "backend_type" in Kccall(Printf.sprintf "caml_sys_const_%s" const_name, 1) | Pisint -> Kisint | Pisout -> Kisout @@ -394,20 +400,20 @@ let comp_primitive p args = | Paddbint bi -> comp_bint_primitive bi "add" args | Psubbint bi -> comp_bint_primitive bi "sub" args | Pmulbint bi -> comp_bint_primitive bi "mul" args - | Pdivbint bi -> comp_bint_primitive bi "div" args - | Pmodbint bi -> comp_bint_primitive bi "mod" args + | Pdivbint { size = bi } -> comp_bint_primitive bi "div" args + | Pmodbint { size = bi } -> comp_bint_primitive bi "mod" args | Pandbint bi -> comp_bint_primitive bi "and" args | Porbint bi -> comp_bint_primitive bi "or" args | Pxorbint bi -> comp_bint_primitive bi "xor" args | Plslbint bi -> comp_bint_primitive bi "shift_left" args | Plsrbint bi -> comp_bint_primitive bi "shift_right_unsigned" args | Pasrbint bi -> comp_bint_primitive bi "shift_right" args - | Pbintcomp(bi, Ceq) -> Kccall("caml_equal", 2) - | Pbintcomp(bi, Cneq) -> Kccall("caml_notequal", 2) - | Pbintcomp(bi, Clt) -> Kccall("caml_lessthan", 2) - | Pbintcomp(bi, Cgt) -> Kccall("caml_greaterthan", 2) - | Pbintcomp(bi, Cle) -> Kccall("caml_lessequal", 2) - | Pbintcomp(bi, Cge) -> Kccall("caml_greaterequal", 2) + | Pbintcomp(_, Ceq) -> Kccall("caml_equal", 2) + | Pbintcomp(_, Cneq) -> Kccall("caml_notequal", 2) + | Pbintcomp(_, Clt) -> Kccall("caml_lessthan", 2) + | Pbintcomp(_, Cgt) -> Kccall("caml_greaterthan", 2) + | Pbintcomp(_, Cle) -> Kccall("caml_lessequal", 2) + | Pbintcomp(_, Cge) -> Kccall("caml_greaterequal", 2) | Pbigarrayref(_, n, _, _) -> Kccall("caml_ba_get_" ^ string_of_int n, n + 1) | Pbigarrayset(_, n, _, _) -> Kccall("caml_ba_set_" ^ string_of_int n, n + 2) | Pbigarraydim(n) -> Kccall("caml_ba_dim_" ^ string_of_int n, 1) @@ -497,7 +503,7 @@ let rec comp_expr env exp sz cont = comp_args env args' (sz + 3) (getmethod :: Kapply nargs :: cont1) end - | Lfunction{kind; params; body} -> (* assume kind = Curried *) + | Lfunction{params; body} -> (* assume kind = Curried *) let lbl = new_label() in let fv = IdentSet.elements(free_variables exp) in let to_compile = @@ -506,7 +512,7 @@ let rec comp_expr env exp sz cont = Stack.push to_compile functions_to_compile; comp_args env (List.map (fun n -> Lvar n) fv) sz (Kclosure(lbl, List.length fv) :: cont) - | Llet(str, id, arg, body) -> + | Llet(_str, _k, id, arg, body) -> comp_expr env arg sz (Kpush :: comp_expr (add_var id (sz+1) env) body (sz+1) (add_pop 1 cont)) @@ -517,10 +523,10 @@ let rec comp_expr env exp sz cont = (* let rec of functions *) let fv = IdentSet.elements (free_variables (Lletrec(decl, lambda_unit))) in - let rec_idents = List.map (fun (id, lam) -> id) decl in + let rec_idents = List.map (fun (id, _lam) -> id) decl in let rec comp_fun pos = function [] -> [] - | (id, Lfunction{kind; params; body}) :: rem -> + | (_id, Lfunction{params; body}) :: rem -> let lbl = new_label() in let to_compile = { params = params; body = body; label = lbl; free_vars = fv; @@ -538,49 +544,50 @@ let rec comp_expr env exp sz cont = List.map (fun (id, exp) -> (id, exp, size_of_lambda exp)) decl in let rec comp_init new_env sz = function | [] -> comp_nonrec new_env sz ndecl decl_size - | (id, exp, RHS_floatblock blocksize) :: rem -> + | (id, _exp, RHS_floatblock blocksize) :: rem -> Kconst(Const_base(Const_int blocksize)) :: Kccall("caml_alloc_dummy_float", 1) :: Kpush :: comp_init (add_var id (sz+1) new_env) (sz+1) rem - | (id, exp, RHS_block blocksize) :: rem -> + | (id, _exp, RHS_block blocksize) :: rem -> Kconst(Const_base(Const_int blocksize)) :: Kccall("caml_alloc_dummy", 1) :: Kpush :: comp_init (add_var id (sz+1) new_env) (sz+1) rem - | (id, exp, RHS_function (blocksize,arity)) :: rem -> + | (id, _exp, RHS_function (blocksize,arity)) :: rem -> Kconst(Const_base(Const_int arity)) :: Kpush :: Kconst(Const_base(Const_int blocksize)) :: Kccall("caml_alloc_dummy_function", 2) :: Kpush :: comp_init (add_var id (sz+1) new_env) (sz+1) rem - | (id, exp, RHS_nonrec) :: rem -> + | (id, _exp, RHS_nonrec) :: rem -> Kconst(Const_base(Const_int 0)) :: Kpush :: comp_init (add_var id (sz+1) new_env) (sz+1) rem and comp_nonrec new_env sz i = function | [] -> comp_rec new_env sz ndecl decl_size - | (id, exp, (RHS_block _ | RHS_floatblock _ | RHS_function _)) + | (_id, _exp, (RHS_block _ | RHS_floatblock _ | RHS_function _)) :: rem -> comp_nonrec new_env sz (i-1) rem - | (id, exp, RHS_nonrec) :: rem -> + | (_id, exp, RHS_nonrec) :: rem -> comp_expr new_env exp sz (Kassign (i-1) :: comp_nonrec new_env sz (i-1) rem) and comp_rec new_env sz i = function | [] -> comp_expr new_env body sz (add_pop ndecl cont) - | (id, exp, (RHS_block _ | RHS_floatblock _ | RHS_function _)) + | (_id, exp, (RHS_block _ | RHS_floatblock _ | RHS_function _)) :: rem -> comp_expr new_env exp sz (Kpush :: Kacc i :: Kccall("caml_update_dummy", 2) :: comp_rec new_env sz (i-1) rem) - | (id, exp, RHS_nonrec) :: rem -> + | (_id, _exp, RHS_nonrec) :: rem -> comp_rec new_env sz (i-1) rem in comp_init env sz decl_size end - | Lprim((Pidentity | Popaque), [arg]) -> + | Lprim((Pidentity | Popaque | Pbytes_to_string | Pbytes_of_string), [arg], _) + -> comp_expr env arg sz cont - | Lprim(Pignore, [arg]) -> + | Lprim(Pignore, [arg], _) -> comp_expr env arg sz (add_const_unit cont) - | Lprim(Pdirapply loc, [func;arg]) - | Lprim(Prevapply loc, [arg;func]) -> + | Lprim(Pdirapply, [func;arg], loc) + | Lprim(Prevapply, [arg;func], loc) -> let exp = Lapply{ap_should_be_tailcall=false; ap_loc=loc; ap_func=func; @@ -588,14 +595,14 @@ let rec comp_expr env exp sz cont = ap_inlined=Default_inline; ap_specialised=Default_specialise} in comp_expr env exp sz cont - | Lprim(Pnot, [arg]) -> + | Lprim(Pnot, [arg], _) -> let newcont = match cont with Kbranchif lbl :: cont1 -> Kbranchifnot lbl :: cont1 | Kbranchifnot lbl :: cont1 -> Kbranchif lbl :: cont1 | _ -> Kboolnot :: cont in comp_expr env arg sz newcont - | Lprim(Psequand, [exp1; exp2]) -> + | Lprim(Psequand, [exp1; exp2], _) -> begin match cont with Kbranchifnot lbl :: _ -> comp_expr env exp1 sz (Kbranchifnot lbl :: @@ -609,7 +616,7 @@ let rec comp_expr env exp sz cont = comp_expr env exp1 sz (Kstrictbranchifnot lbl :: comp_expr env exp2 sz cont1) end - | Lprim(Psequor, [exp1; exp2]) -> + | Lprim(Psequor, [exp1; exp2], _) -> begin match cont with Kbranchif lbl :: _ -> comp_expr env exp1 sz (Kbranchif lbl :: @@ -623,21 +630,21 @@ let rec comp_expr env exp sz cont = comp_expr env exp1 sz (Kstrictbranchif lbl :: comp_expr env exp2 sz cont1) end - | Lprim(Praise k, [arg]) -> + | Lprim(Praise k, [arg], _) -> comp_expr env arg sz (Kraise k :: discard_dead_code cont) - | Lprim(Paddint, [arg; Lconst(Const_base(Const_int n))]) + | Lprim(Paddint, [arg; Lconst(Const_base(Const_int n))], _) when is_immed n -> comp_expr env arg sz (Koffsetint n :: cont) - | Lprim(Psubint, [arg; Lconst(Const_base(Const_int n))]) + | Lprim(Psubint, [arg; Lconst(Const_base(Const_int n))], _) when is_immed (-n) -> comp_expr env arg sz (Koffsetint (-n) :: cont) - | Lprim (Poffsetint n, [arg]) + | Lprim (Poffsetint n, [arg], _) when not (is_immed n) -> comp_expr env arg sz (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) @@ -650,22 +657,23 @@ 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)]) -> + | Lprim (Pduparray (kind, mutability), + [Lprim (Pmakearray (kind',_),args,_)], loc) -> assert (kind = kind'); - comp_expr env (Lprim (Pmakearray (kind, mutability), args)) sz cont - | Lprim (Pduparray _, [arg]) -> + comp_expr env (Lprim (Pmakearray (kind, mutability), args, loc)) sz cont + | Lprim (Pduparray _, [arg], loc) -> 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 _, _) -> + comp_expr env (Lprim (Pccall prim_obj_dup, [arg], loc)) 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)]) -> + | Lprim (Pintcomp c, [arg ; (Lconst _ as k)], _) -> let p = Pintcomp (commute_comparison c) and args = [k ; arg] in comp_args env args sz (comp_primitive p args :: cont) - | Lprim(p, args) -> + | Lprim(p, args, _) -> comp_args env args sz (comp_primitive p args :: cont) | Lstaticcatch (body, (i, vars) , handler) -> let nvars = List.length vars in @@ -791,8 +799,8 @@ let rec comp_expr env exp sz cont = lbl_consts.(i) <- lbls.(act_consts.(i)) done; comp_expr env arg sz (Kswitch(lbl_consts, lbl_blocks) :: !c) - | Lstringswitch (arg,sw,d) -> - comp_expr env (Matching.expand_stringswitch arg sw d) sz cont + | Lstringswitch (arg,sw,d,loc) -> + comp_expr env (Matching.expand_stringswitch loc arg sw d) sz cont | Lassign(id, expr) -> begin try let pos = Ident.find_same id env.ce_stack in diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml index e77920b6..660c1eaa 100644 --- a/bytecomp/bytelink.ml +++ b/bytecomp/bytelink.ml @@ -29,6 +29,7 @@ type error = | File_exists of string | Cannot_open_dll of string | Not_compatible_32 + | Required_module_unavailable of string exception Error of error @@ -89,19 +90,26 @@ module IdentSet = Lambda.IdentSet let missing_globals = ref IdentSet.empty -let is_required (rel, pos) = +let is_required (rel, _pos) = match rel with Reloc_setglobal id -> IdentSet.mem id !missing_globals | _ -> false -let add_required (rel, pos) = - match rel with - Reloc_getglobal id -> - missing_globals := IdentSet.add id !missing_globals - | _ -> () - -let remove_required (rel, pos) = +let add_required compunit = + let add_required_by_reloc (rel, _pos) = + match rel with + Reloc_getglobal id -> + missing_globals := IdentSet.add id !missing_globals + | _ -> () + in + let add_required_for_effects id = + missing_globals := IdentSet.add id !missing_globals + in + List.iter add_required_by_reloc compunit.cu_reloc; + List.iter add_required_for_effects compunit.cu_required_globals + +let remove_required (rel, _pos) = match rel with Reloc_setglobal id -> missing_globals := IdentSet.remove id !missing_globals @@ -124,7 +132,8 @@ let scan_file obj_name tolink = seek_in ic compunit_pos; let compunit = (input_value ic : compilation_unit) in close_in ic; - List.iter add_required compunit.cu_reloc; + add_required compunit; + List.iter remove_required compunit.cu_reloc; Link_object(file_name, compunit) :: tolink end else if buffer = cma_magic_number then begin @@ -142,8 +151,8 @@ let scan_file obj_name tolink = || !Clflags.link_everything || List.exists is_required compunit.cu_reloc then begin + add_required compunit; List.iter remove_required compunit.cu_reloc; - List.iter add_required compunit.cu_reloc; compunit :: reqd end else reqd) @@ -318,7 +327,7 @@ let link_bytecode ppf tolink exec_name standalone = Bytesections.init_record outchan; (* The path to the bytecode interpreter (in use_runtime mode) *) if String.length !Clflags.use_runtime > 0 then begin - output_string outchan ("#!" ^ (make_absolute !Clflags.use_runtime)); + output_string outchan (make_absolute !Clflags.use_runtime); output_char outchan '\n'; Bytesections.record outchan "RNTM" end; @@ -538,6 +547,14 @@ let link ppf objfiles output_name = else if !Clflags.output_c_object then "stdlib.cma" :: objfiles else "stdlib.cma" :: (objfiles @ ["std_exit.cmo"]) in let tolink = List.fold_right scan_file objfiles [] in + let missing_modules = + IdentSet.filter (fun id -> not (Ident.is_predef_exn id)) !missing_globals + in + begin + match IdentSet.elements missing_modules with + | [] -> () + | id :: _ -> raise (Error (Required_module_unavailable (Ident.name id))) + end; Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs; (* put user's libs last *) Clflags.all_ccopts := !lib_ccopts @ !Clflags.all_ccopts; (* put user's opts first *) @@ -654,6 +671,8 @@ let report_error ppf = function | Not_compatible_32 -> fprintf ppf "Generated bytecode executable cannot be run\ \ on a 32-bit platform" + | Required_module_unavailable s -> + fprintf ppf "Required module `%s' is unavailable" s let () = Location.register_error_of_exn diff --git a/bytecomp/bytelink.mli b/bytecomp/bytelink.mli index 113207fe..42084fe7 100644 --- a/bytecomp/bytelink.mli +++ b/bytecomp/bytelink.mli @@ -33,6 +33,7 @@ type error = | File_exists of string | Cannot_open_dll of string | Not_compatible_32 + | Required_module_unavailable of string exception Error of error diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml index 869cab79..2471ad59 100644 --- a/bytecomp/bytepackager.ml +++ b/bytecomp/bytepackager.ml @@ -186,7 +186,7 @@ let rec rename_append_bytecode_list ppf packagename oc mapping defined ofs let build_global_target oc target_name members mapping pos coercion = let components = List.map2 - (fun m (id1, id2) -> + (fun m (_id1, id2) -> match m.pm_kind with | PM_intf -> None | PM_impl _ -> Some id2) @@ -207,6 +207,24 @@ let build_global_target oc target_name members mapping pos coercion = let package_object_files ppf files targetfile targetname coercion = let members = map_left_right read_member_info files in + let required_globals = + List.fold_right (fun compunit required_globals -> match compunit with + | { pm_kind = PM_intf } -> + required_globals + | { pm_kind = PM_impl { cu_required_globals; cu_reloc } } -> + let remove_required (rel, _pos) required_globals = + match rel with + Reloc_setglobal id -> + Ident.Set.remove id required_globals + | _ -> + required_globals + in + let required_globals = + List.fold_right remove_required cu_reloc required_globals + in + List.fold_right Ident.Set.add cu_required_globals required_globals) + members Ident.Set.empty + in let unit_names = List.map (fun m -> m.pm_name) members in let mapping = @@ -232,7 +250,7 @@ let package_object_files ppf files targetfile targetname coercion = let pos_final = pos_out oc in let imports = List.filter - (fun (name, crc) -> not (List.mem name unit_names)) + (fun (name, _crc) -> not (List.mem name unit_names)) (Bytelink.extract_crc_interfaces()) in let compunit = { cu_name = targetname; @@ -242,6 +260,7 @@ let package_object_files ppf files targetfile targetname coercion = cu_imports = (targetname, Some (Env.crc_of_unit targetname)) :: imports; cu_primitives = !primitives; + cu_required_globals = Ident.Set.elements required_globals; cu_force_link = !force_link; cu_debug = if pos_final > pos_debug then pos_debug else 0; cu_debugsize = pos_final - pos_debug } in diff --git a/bytecomp/bytesections.ml b/bytecomp/bytesections.ml index 061e0923..2beb0761 100644 --- a/bytecomp/bytesections.ml +++ b/bytecomp/bytesections.ml @@ -94,7 +94,7 @@ let read_section_struct ic name = let pos_first_section ic = in_channel_length ic - 16 - 8 * List.length !section_table - - List.fold_left (fun total (name, len) -> total + len) 0 !section_table + List.fold_left (fun total (_name, len) -> total + len) 0 !section_table let reset () = section_table := []; diff --git a/bytecomp/cmo_format.mli b/bytecomp/cmo_format.mli index fe14af0b..7fbb35a0 100644 --- a/bytecomp/cmo_format.mli +++ b/bytecomp/cmo_format.mli @@ -32,6 +32,9 @@ type compilation_unit = cu_reloc: (reloc_info * int) list; (* Relocation information *) cu_imports: (string * Digest.t option) list; (* Names and CRC of intfs imported *) + cu_required_globals: Ident.t list; (* Compilation units whose initialization + side effects must occur before this + one. *) cu_primitives: string list; (* Primitives declared inside *) mutable cu_force_link: bool; (* Must be linked even if unref'ed *) mutable cu_debug: int; (* Position of debugging info, or 0 *) diff --git a/bytecomp/debuginfo.ml b/bytecomp/debuginfo.ml deleted file mode 100644 index 1ef4de27..00000000 --- a/bytecomp/debuginfo.ml +++ /dev/null @@ -1,81 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Lexing -open Location - -type kind = Dinfo_call | Dinfo_raise - -type t = { - dinfo_kind: kind; - dinfo_file: string; - dinfo_line: int; - dinfo_char_start: int; - dinfo_char_end: int -} - -let none = { - dinfo_kind = Dinfo_call; - dinfo_file = ""; - dinfo_line = 0; - dinfo_char_start = 0; - dinfo_char_end = 0 -} - -(* PR#5643: cannot use (==) because Debuginfo values are marshalled *) -let is_none t = - t = none - -let to_string d = - if d = none - then "" - else Printf.sprintf "{%s:%d,%d-%d}" - d.dinfo_file d.dinfo_line d.dinfo_char_start d.dinfo_char_end - -let from_filename kind filename = { - dinfo_kind = kind; - dinfo_file = filename; - dinfo_line = 0; - dinfo_char_start = 0; - dinfo_char_end = 0 -} - -let from_location kind loc = - if loc == Location.none then none else - { dinfo_kind = kind; - dinfo_file = loc.loc_start.pos_fname; - dinfo_line = loc.loc_start.pos_lnum; - dinfo_char_start = loc.loc_start.pos_cnum - loc.loc_start.pos_bol; - dinfo_char_end = - if loc.loc_end.pos_fname = loc.loc_start.pos_fname - then loc.loc_end.pos_cnum - loc.loc_start.pos_bol - else loc.loc_start.pos_cnum - loc.loc_start.pos_bol } - -let from_call ev = from_location Dinfo_call ev.Lambda.lev_loc -let from_raise ev = from_location Dinfo_raise ev.Lambda.lev_loc - -let to_location d = - if is_none d then Location.none - else - let loc_start = - { Lexing. - pos_fname = d.dinfo_file; - pos_lnum = d.dinfo_line; - pos_bol = 0; - pos_cnum = d.dinfo_char_start; - } - in - let loc_end = { loc_start with pos_cnum = d.dinfo_char_end; } in - { Location. loc_ghost = false; loc_start; loc_end; } diff --git a/bytecomp/debuginfo.mli b/bytecomp/debuginfo.mli deleted file mode 100644 index b80fe99c..00000000 --- a/bytecomp/debuginfo.mli +++ /dev/null @@ -1,38 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -type kind = Dinfo_call | Dinfo_raise - -type t = private { - dinfo_kind: kind; - dinfo_file: string; - dinfo_line: int; - dinfo_char_start: int; - dinfo_char_end: int -} - -val none: t - -val is_none: t -> bool - -val to_string: t -> string - -val from_location: kind -> Location.t -> t -val from_filename: kind -> string -> t - -val from_call: Lambda.lambda_event -> t -val from_raise: Lambda.lambda_event -> t - -val to_location: t -> Location.t diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml index 0b09b87b..7857202e 100644 --- a/bytecomp/emitcode.ml +++ b/bytecomp/emitcode.ml @@ -365,7 +365,7 @@ let rec emit = function (* Emission to a file *) -let to_file outchan unit_name objfile code = +let to_file outchan unit_name objfile ~required_globals code = init(); output_string outchan cmo_magic_number; let pos_depl = pos_out outchan in @@ -392,6 +392,7 @@ let to_file outchan unit_name objfile code = cu_imports = Env.imports(); cu_primitives = List.map Primitive.byte_name !Translmod.primitive_declarations; + cu_required_globals = Ident.Set.elements required_globals; cu_force_link = false; cu_debug = pos_debug; cu_debugsize = size_debug } in diff --git a/bytecomp/emitcode.mli b/bytecomp/emitcode.mli index f4716e03..74a785ee 100644 --- a/bytecomp/emitcode.mli +++ b/bytecomp/emitcode.mli @@ -18,11 +18,14 @@ open Cmo_format open Instruct -val to_file: out_channel -> string -> string -> instruction list -> unit +val to_file: out_channel -> string -> string -> + required_globals:Ident.Set.t -> instruction list -> unit (* Arguments: channel on output file name of compilation unit implemented path of cmo file being written + required_globals: list of compilation units that must be + evaluated before this one list of instructions to emit *) val to_memory: instruction list -> instruction list -> bytes * int * (reloc_info * int) list * debug_event list diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index b3011291..b087ca52 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -25,6 +25,7 @@ type compile_time_constant = | Ostype_unix | Ostype_win32 | Ostype_cygwin + | Backend_type type loc_kind = | Loc_FILE @@ -41,17 +42,23 @@ type initialization_or_assignment = | Initialization | Assignment +type is_safe = + | Safe + | Unsafe + type primitive = - Pidentity + | Pidentity + | Pbytes_to_string + | Pbytes_of_string | Pignore - | Prevapply of Location.t - | Pdirapply of Location.t + | Prevapply + | Pdirapply | Ploc of loc_kind (* Globals *) | Pgetglobal of Ident.t | Psetglobal of Ident.t (* Operations on heap blocks *) - | Pmakeblock of int * mutable_flag + | Pmakeblock of int * mutable_flag * block_shape | Pfield of int | Psetfield of int * immediate_or_pointer * initialization_or_assignment | Pfloatfield of int @@ -66,7 +73,8 @@ type primitive = (* Boolean operations *) | Psequand | Psequor | Pnot (* Integer operations *) - | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint + | Pnegint | Paddint | Psubint | Pmulint + | Pdivint of is_safe | Pmodint of is_safe | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint | Pintcomp of comparison @@ -78,7 +86,8 @@ type primitive = | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat | Pfloatcomp of comparison (* String operations *) - | Pstringlength | Pstringrefu | Pstringsetu | Pstringrefs | Pstringsets + | Pstringlength | Pstringrefu | Pstringrefs + | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets (* Array operations *) | Pmakearray of array_kind * mutable_flag | Pduparray of array_kind * mutable_flag @@ -101,8 +110,8 @@ type primitive = | Paddbint of boxed_integer | Psubbint of boxed_integer | Pmulbint of boxed_integer - | Pdivbint of boxed_integer - | Pmodbint of boxed_integer + | Pdivbint of { size : boxed_integer; is_safe : is_safe } + | Pmodbint of { size : boxed_integer; is_safe : is_safe } | Pandbint of boxed_integer | Porbint of boxed_integer | Pxorbint of boxed_integer @@ -143,6 +152,12 @@ type primitive = and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge +and value_kind = + Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval + +and block_shape = + value_kind list option + and array_kind = Pgenarray | Paddrarray | Pintarray | Pfloatarray @@ -205,11 +220,12 @@ type lambda = | Lconst of structured_constant | Lapply of lambda_apply | Lfunction of lfunction - | Llet of let_kind * Ident.t * lambda * lambda + | Llet of let_kind * value_kind * Ident.t * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda - | Lprim of primitive * lambda list + | Lprim of primitive * lambda list * Location.t | Lswitch of lambda * lambda_switch - | Lstringswitch of lambda * (string * lambda) list * lambda option + | Lstringswitch of + lambda * (string * lambda) list * lambda option * Location.t | Lstaticraise of int * lambda list | Lstaticcatch of lambda * (int * Ident.t list) * lambda | Ltrywith of lambda * Ident.t * lambda @@ -226,7 +242,8 @@ and lfunction = { kind: function_kind; params: Ident.t list; body: lambda; - attr: function_attribute; } (* specified with [@inline] attribute *) + attr: function_attribute; (* specified with [@inline] attribute *) + loc: Location.t; } and lambda_apply = { ap_func : lambda; @@ -256,8 +273,10 @@ and lambda_event_kind = | Lev_pseudo type program = - { code : lambda; - main_module_block_size : int; } + { module_ident : Ident.t; + main_module_block_size : int; + required_globals : Ident.Set.t; + code : lambda } let const_unit = Const_pointer 0 @@ -300,23 +319,26 @@ let make_key e = Lapply {ap with ap_func = tr_rec env ap.ap_func; ap_args = tr_recs env ap.ap_args; ap_loc = Location.none} - | Llet (Alias,x,ex,e) -> (* Ignore aliases -> substitute *) + | Llet (Alias,_k,x,ex,e) -> (* Ignore aliases -> substitute *) let ex = tr_rec env ex in tr_rec (Ident.add x ex env) e - | Llet (str,x,ex,e) -> + | Llet ((Strict | StrictOpt),_k,x,ex,Lvar v) when Ident.same v x -> + tr_rec env ex + | Llet (str,k,x,ex,e) -> (* Because of side effects, keep other lets with normalized names *) let ex = tr_rec env ex in let y = make_key x in - Llet (str,y,ex,tr_rec (Ident.add x (Lvar y) env) e) - | Lprim (p,es) -> - Lprim (p,tr_recs env es) + Llet (str,k,y,ex,tr_rec (Ident.add x (Lvar y) env) e) + | Lprim (p,es,_) -> + Lprim (p,tr_recs env es, Location.none) | Lswitch (e,sw) -> Lswitch (tr_rec env e,tr_sw env sw) - | Lstringswitch (e,sw,d) -> + | Lstringswitch (e,sw,d,_) -> Lstringswitch (tr_rec env e, List.map (fun (s,e) -> s,tr_rec env e) sw, - tr_opt env d) + tr_opt env d, + Location.none) | Lstaticraise (i,es) -> Lstaticraise (i,tr_recs env es) | Lstaticcatch (e1,xs,e2) -> @@ -329,7 +351,7 @@ let make_key e = Lsequence (tr_rec env e1,tr_rec env e2) | Lassign (x,e) -> Lassign (x,tr_rec env e) - | Lsend (m,e1,e2,es,loc) -> + | Lsend (m,e1,e2,es,_loc) -> Lsend (m,tr_rec env e1,tr_rec env e2,tr_recs env es,Location.none) | Lifused (id,e) -> Lifused (id,tr_rec env e) | Lletrec _|Lfunction _ @@ -360,16 +382,16 @@ let make_key e = let name_lambda strict arg fn = match arg with Lvar id -> fn id - | _ -> let id = Ident.create "let" in Llet(strict, id, arg, fn id) + | _ -> let id = Ident.create "let" in Llet(strict, Pgenval, id, arg, fn id) let name_lambda_list args fn = let rec name_list names = function [] -> fn (List.rev names) - | (Lvar id as arg) :: rem -> + | (Lvar _ as arg) :: rem -> name_list (arg :: names) rem | arg :: rem -> let id = Ident.create "let" in - Llet(Strict, id, arg, name_list (Lvar id :: names) rem) in + Llet(Strict, Pgenval, id, arg, name_list (Lvar id :: names) rem) in name_list [] args @@ -382,29 +404,29 @@ let iter f = function | Lconst _ -> () | Lapply{ap_func = fn; ap_args = args} -> f fn; List.iter f args - | Lfunction{kind; params; body} -> + | Lfunction{body} -> f body - | Llet(str, id, arg, body) -> + | Llet(_str, _k, _id, arg, body) -> f arg; f body | Lletrec(decl, body) -> f body; - List.iter (fun (id, exp) -> f exp) decl - | Lprim(p, args) -> + List.iter (fun (_id, exp) -> f exp) decl + | Lprim(_p, args, _loc) -> List.iter f args | Lswitch(arg, sw) -> f arg; - List.iter (fun (key, case) -> f case) sw.sw_consts; - List.iter (fun (key, case) -> f case) sw.sw_blocks; + List.iter (fun (_key, case) -> f case) sw.sw_consts; + List.iter (fun (_key, case) -> f case) sw.sw_blocks; iter_opt f sw.sw_failaction - | Lstringswitch (arg,cases,default) -> + | Lstringswitch (arg,cases,default,_) -> f arg ; List.iter (fun (_,act) -> f act) cases ; iter_opt f default | Lstaticraise (_,args) -> List.iter f args - | Lstaticcatch(e1, (_,vars), e2) -> + | Lstaticcatch(e1, _, e2) -> f e1; f e2 - | Ltrywith(e1, exn, e2) -> + | Ltrywith(e1, _, e2) -> f e1; f e2 | Lifthenelse(e1, e2, e3) -> f e1; f e2; f e3 @@ -412,23 +434,19 @@ let iter f = function f e1; f e2 | Lwhile(e1, e2) -> f e1; f e2 - | Lfor(v, e1, e2, dir, e3) -> + | Lfor(_v, e1, e2, _dir, e3) -> f e1; f e2; f e3 - | Lassign(id, e) -> + | Lassign(_, e) -> f e - | Lsend (k, met, obj, args, _) -> + | Lsend (_k, met, obj, args, _) -> List.iter f (met::obj::args) - | Levent (lam, evt) -> + | Levent (lam, _evt) -> f lam - | Lifused (v, e) -> + | Lifused (_v, e) -> f e -module IdentSet = - Set.Make(struct - type t = Ident.t - let compare = compare - end) +module IdentSet = Set.Make(Ident) let free_ids get l = let fv = ref IdentSet.empty in @@ -436,19 +454,19 @@ let free_ids get l = iter free l; fv := List.fold_right IdentSet.add (get l) !fv; match l with - Lfunction{kind; params; body} -> + Lfunction{params} -> List.iter (fun param -> fv := IdentSet.remove param !fv) params - | Llet(str, id, arg, body) -> + | Llet(_str, _k, id, _arg, _body) -> fv := IdentSet.remove id !fv - | Lletrec(decl, body) -> - List.iter (fun (id, exp) -> fv := IdentSet.remove id !fv) decl - | Lstaticcatch(e1, (_,vars), e2) -> + | Lletrec(decl, _body) -> + List.iter (fun (id, _exp) -> fv := IdentSet.remove id !fv) decl + | Lstaticcatch(_e1, (_,vars), _e2) -> List.iter (fun id -> fv := IdentSet.remove id !fv) vars - | Ltrywith(e1, exn, e2) -> + | Ltrywith(_e1, exn, _e2) -> fv := IdentSet.remove exn !fv - | Lfor(v, e1, e2, dir, e3) -> + | Lfor(v, _e1, _e2, _dir, _e3) -> fv := IdentSet.remove v !fv - | Lassign(id, e) -> + | Lassign(id, _e) -> fv := IdentSet.add id !fv | Lvar _ | Lconst _ | Lapply _ | Lprim _ | Lswitch _ | Lstringswitch _ | Lstaticraise _ @@ -460,7 +478,7 @@ let free_variables l = free_ids (function Lvar id -> [id] | _ -> []) l let free_methods l = - free_ids (function Lsend(Self, Lvar meth, obj, _, _) -> [meth] | _ -> []) l + free_ids (function Lsend(Self, Lvar meth, _, _, _) -> [meth] | _ -> []) l (* Check if an action has a "when" guard *) let raise_count = ref 0 @@ -479,16 +497,16 @@ let next_negative_raise_count () = let staticfail = Lstaticraise (0,[]) let rec is_guarded = function - | Lifthenelse( cond, body, Lstaticraise (0,[])) -> true - | Llet(str, id, lam, body) -> is_guarded body - | Levent(lam, ev) -> is_guarded lam + | Lifthenelse(_cond, _body, Lstaticraise (0,[])) -> true + | Llet(_str, _k, _id, _lam, body) -> is_guarded body + | Levent(lam, _ev) -> is_guarded lam | _ -> false let rec patch_guarded patch = function | Lifthenelse (cond, body, Lstaticraise (0,[])) -> Lifthenelse (cond, body, patch) - | Llet(str, id, lam, body) -> - Llet (str, id, lam, patch_guarded patch body) + | Llet(str, k, id, lam, body) -> + Llet (str, k, id, lam, patch_guarded patch body) | Levent(lam, ev) -> Levent (patch_guarded patch lam, ev) | _ -> fatal_error "Lambda.patch_guarded" @@ -497,10 +515,12 @@ let rec patch_guarded patch = function let rec transl_normal_path = function Pident id -> - if Ident.global id then Lprim(Pgetglobal id, []) else Lvar id - | Pdot(p, s, pos) -> - Lprim(Pfield pos, [transl_normal_path p]) - | Papply(p1, p2) -> + if Ident.global id + then Lprim(Pgetglobal id, [], Location.none) + else Lvar id + | Pdot(p, _s, pos) -> + Lprim(Pfield pos, [transl_normal_path p], Location.none) + | Papply _ -> fatal_error "Lambda.transl_path" (* Translation of value identifiers *) @@ -526,23 +546,23 @@ let subst_lambda s lam = let rec subst = function Lvar id as l -> begin try Ident.find_same id s with Not_found -> l end - | Lconst sc as l -> l + | Lconst _ as l -> l | Lapply ap -> Lapply{ap with ap_func = subst ap.ap_func; ap_args = List.map subst ap.ap_args} - | Lfunction{kind; params; body; attr} -> - Lfunction{kind; params; body = subst body; attr} - | Llet(str, id, arg, body) -> Llet(str, id, subst arg, subst body) + | Lfunction{kind; params; body; attr; loc} -> + Lfunction{kind; params; body = subst body; attr; loc} + | Llet(str, k, id, arg, body) -> Llet(str, k, id, subst arg, subst body) | Lletrec(decl, body) -> Lletrec(List.map subst_decl decl, subst body) - | Lprim(p, args) -> Lprim(p, List.map subst args) + | Lprim(p, args, loc) -> Lprim(p, List.map subst args, loc) | Lswitch(arg, sw) -> Lswitch(subst arg, {sw with sw_consts = List.map subst_case sw.sw_consts; sw_blocks = List.map subst_case sw.sw_blocks; sw_failaction = subst_opt sw.sw_failaction; }) - | Lstringswitch (arg,cases,default) -> + | Lstringswitch (arg,cases,default,loc) -> Lstringswitch - (subst arg,List.map subst_strcase cases,subst_opt default) + (subst arg,List.map subst_strcase cases,subst_opt default,loc) | Lstaticraise (i,args) -> Lstaticraise (i, List.map subst args) | Lstaticcatch(e1, io, e2) -> Lstaticcatch(subst e1, io, subst e2) | Ltrywith(e1, exn, e2) -> Ltrywith(subst e1, exn, subst e2) @@ -566,8 +586,8 @@ let subst_lambda s lam = let rec map f lam = let lam = match lam with - | Lvar v -> lam - | Lconst cst -> lam + | Lvar _ -> lam + | Lconst _ -> lam | Lapply { ap_func; ap_args; ap_loc; ap_should_be_tailcall; ap_inlined; ap_specialised } -> Lapply { @@ -578,14 +598,14 @@ let rec map f lam = ap_inlined; ap_specialised; } - | Lfunction { kind; params; body; attr; } -> - Lfunction { kind; params; body = map f body; attr; } - | Llet (str, v, e1, e2) -> - Llet (str, v, map f e1, map f e2) + | Lfunction { kind; params; body; attr; loc; } -> + Lfunction { kind; params; body = map f body; attr; loc; } + | Llet (str, k, v, e1, e2) -> + Llet (str, k, v, map f e1, map f e2) | Lletrec (idel, e2) -> Lletrec (List.map (fun (v, e) -> (v, map f e)) idel, map f e2) - | Lprim (p, el) -> - Lprim (p, List.map (map f) el) + | Lprim (p, el, loc) -> + Lprim (p, List.map (map f) el, loc) | Lswitch (e, sw) -> Lswitch (map f e, { sw_numconsts = sw.sw_numconsts; @@ -594,11 +614,12 @@ let rec map f lam = sw_blocks = List.map (fun (n, e) -> (n, map f e)) sw.sw_blocks; sw_failaction = Misc.may_map (map f) sw.sw_failaction; }) - | Lstringswitch (e, sw, default) -> + | Lstringswitch (e, sw, default, loc) -> Lstringswitch ( map f e, List.map (fun (s, e) -> (s, map f e)) sw, - Misc.may_map (map f) default) + Misc.may_map (map f) default, + loc) | Lstaticraise (i, args) -> Lstaticraise (i, List.map (map f) args) | Lstaticcatch (body, id, handler) -> @@ -629,7 +650,7 @@ let rec map f lam = let bind str var exp body = match exp with Lvar var' when Ident.same var var' -> body - | _ -> Llet(str, var, exp, body) + | _ -> Llet(str, Pgenval, var, exp, body) and commute_comparison = function | Ceq -> Ceq| Cneq -> Cneq diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index def712af..f346b0e7 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -25,6 +25,7 @@ type compile_time_constant = | Ostype_unix | Ostype_win32 | Ostype_cygwin + | Backend_type type loc_kind = | Loc_FILE @@ -44,17 +45,23 @@ type initialization_or_assignment = | Initialization | Assignment +type is_safe = + | Safe + | Unsafe + type primitive = - Pidentity + | Pidentity + | Pbytes_to_string + | Pbytes_of_string | Pignore - | Prevapply of Location.t - | Pdirapply of Location.t + | Prevapply + | Pdirapply | Ploc of loc_kind (* Globals *) | Pgetglobal of Ident.t | Psetglobal of Ident.t (* Operations on heap blocks *) - | Pmakeblock of int * mutable_flag + | Pmakeblock of int * mutable_flag * block_shape | Pfield of int | Psetfield of int * immediate_or_pointer * initialization_or_assignment | Pfloatfield of int @@ -69,7 +76,8 @@ type primitive = (* Boolean operations *) | Psequand | Psequor | Pnot (* Integer operations *) - | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint + | Pnegint | Paddint | Psubint | Pmulint + | Pdivint of is_safe | Pmodint of is_safe | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint | Pintcomp of comparison @@ -81,7 +89,8 @@ type primitive = | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat | Pfloatcomp of comparison (* String operations *) - | Pstringlength | Pstringrefu | Pstringsetu | Pstringrefs | Pstringsets + | Pstringlength | Pstringrefu | Pstringrefs + | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets (* Array operations *) | Pmakearray of array_kind * mutable_flag | Pduparray of array_kind * mutable_flag @@ -107,8 +116,8 @@ type primitive = | Paddbint of boxed_integer | Psubbint of boxed_integer | Pmulbint of boxed_integer - | Pdivbint of boxed_integer - | Pmodbint of boxed_integer + | Pdivbint of { size : boxed_integer; is_safe : is_safe } + | Pmodbint of { size : boxed_integer; is_safe : is_safe } | Pandbint of boxed_integer | Porbint of boxed_integer | Pxorbint of boxed_integer @@ -152,6 +161,12 @@ and comparison = and array_kind = Pgenarray | Paddrarray | Pintarray | Pfloatarray +and value_kind = + Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval + +and block_shape = + value_kind list option + and boxed_integer = Primitive.boxed_integer = Pnativeint | Pint32 | Pint64 @@ -203,7 +218,8 @@ type let_kind = Strict | Alias | StrictOpt | Variable in e' StrictOpt: e does not have side-effects, but depend on the store; we can discard e if x does not appear in e' - Variable: the variable x is assigned later in e' *) + Variable: the variable x is assigned later in e' + *) type meth_kind = Self | Public | Cached @@ -220,13 +236,14 @@ type lambda = | Lconst of structured_constant | Lapply of lambda_apply | Lfunction of lfunction - | Llet of let_kind * Ident.t * lambda * lambda + | Llet of let_kind * value_kind * Ident.t * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda - | Lprim of primitive * lambda list + | Lprim of primitive * lambda list * Location.t | Lswitch of lambda * lambda_switch (* switch on strings, clauses are sorted by string order, strings are pairwise distinct *) - | Lstringswitch of lambda * (string * lambda) list * lambda option + | Lstringswitch of + lambda * (string * lambda) list * lambda option * Location.t | Lstaticraise of int * lambda list | Lstaticcatch of lambda * (int * Ident.t list) * lambda | Ltrywith of lambda * Ident.t * lambda @@ -243,7 +260,8 @@ and lfunction = { kind: function_kind; params: Ident.t list; body: lambda; - attr: function_attribute; } (* specified with [@inline] attribute *) + attr: function_attribute; (* specified with [@inline] attribute *) + loc : Location.t; } and lambda_apply = { ap_func : lambda; @@ -272,10 +290,22 @@ and lambda_event_kind = | Lev_pseudo 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 *) + { module_ident : Ident.t; + main_module_block_size : int; + required_globals : Ident.Set.t; (* Modules whose initializer side effects + must occur before [code]. *) + code : lambda } +(* Lambda code for the middle-end. + * In the closure case the code is a sequence of assignments to a + preallocated block of size [main_module_block_size] using + (Setfield(Getglobal(module_ident))). The size is used to preallocate + the block. + * In the flambda case the code is an expression returning a block + value of size [main_module_block_size]. The size is used to build + the module root as an initialize_symbol + Initialize_symbol(module_name, 0, + [getfield 0; ...; getfield (main_module_block_size - 1)]) +*) (* Sharing key *) val make_key: lambda -> lambda option diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index 7d541606..b2dcd248 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -72,7 +72,7 @@ let lshift {left=left ; right=right} = match right with | _ -> assert false let lforget {left=left ; right=right} = match right with -| x::xs -> {left=omega::left ; right=xs} +| _::xs -> {left=omega::left ; right=xs} | _ -> assert false let rec small_enough n = function @@ -174,7 +174,7 @@ let ctx_matcher p = | Cstr_extension _ -> let nargs = List.length omegas in (fun q rem -> match q.pat_desc with - | Tpat_construct (_, cstr',args) + | Tpat_construct (_, _cstr',args) when List.length args = nargs -> p,args @ rem | Tpat_any -> p,omegas @ rem @@ -396,7 +396,7 @@ type pm_half_compiled_info = let pretty_cases cases = List.iter - (fun ((ps),l) -> + (fun (ps,_l) -> List.iter (fun p -> Parmatch.top_pretty Format.str_formatter p ; @@ -483,7 +483,7 @@ let make_catch d k = match d with (* Introduce a catch, if worth it, delayed version *) let rec as_simple_exit = function | Lstaticraise (i,[]) -> Some i - | Llet (Alias,_,_,e) -> as_simple_exit e + | Llet (Alias,_k,_,_,e) -> as_simple_exit e | _ -> None @@ -1078,7 +1078,7 @@ and precompile_var args cls def k = match args with | [] -> assert false | _::((Lvar v as av,_) as arg)::rargs -> begin match cls with - | [ps,_] -> (* as splitted as it can *) + | [_] -> (* as splitted as it can *) dont_precompile_var args cls def k | _ -> (* Precompile *) @@ -1113,7 +1113,7 @@ and dont_precompile_var args cls def k = and is_exc p = match p.pat_desc with | Tpat_or (p1,p2,_) -> is_exc p1 || is_exc p2 -| Tpat_alias (p,v,_) -> is_exc p +| Tpat_alias (p,_,_) -> is_exc p | Tpat_construct (_,{cstr_tag=Cstr_extension _},_) -> true | _ -> false @@ -1286,11 +1286,11 @@ let divide_constant ctx m = (* Matching against a constructor *) -let make_field_args binding_kind arg first_pos last_pos argl = +let make_field_args loc binding_kind arg first_pos last_pos argl = let rec make_args pos = if pos > last_pos then argl - else (Lprim(Pfield pos, [arg]), binding_kind) :: make_args (pos + 1) + else (Lprim(Pfield pos, [arg], loc), binding_kind) :: make_args (pos + 1) in make_args first_pos let get_key_constr = function @@ -1325,7 +1325,7 @@ let matcher_constr cstr = match cstr.cstr_arity with | None, None -> raise NoMatch | Some r1, None -> r1 | None, Some r2 -> r2 - | Some (a1::rem1), Some (a2::_) -> + | Some (a1::_), Some (a2::_) -> {a1 with pat_loc = Location.none ; pat_desc = Tpat_or (a1, a2, None)}:: @@ -1347,16 +1347,17 @@ let matcher_constr cstr = match cstr.cstr_arity with let make_constr_matching p def ctx = function [] -> fatal_error "Matching.make_constr_matching" - | ((arg, mut) :: argl) -> + | ((arg, _mut) :: argl) -> let cstr = pat_as_constr p in let newargs = if cstr.cstr_inlined <> None then (arg, Alias) :: argl else match cstr.cstr_tag with Cstr_constant _ | Cstr_block _ -> - make_field_args Alias arg 0 (cstr.cstr_arity - 1) argl + make_field_args p.pat_loc Alias arg 0 (cstr.cstr_arity - 1) argl + | Cstr_unboxed -> (arg, Alias) :: argl | Cstr_extension _ -> - make_field_args Alias arg 1 cstr.cstr_arity argl in + make_field_args p.pat_loc Alias arg 1 cstr.cstr_arity argl in {pm= {cases = []; args = newargs; default = make_default (matcher_constr cstr) def} ; @@ -1387,7 +1388,7 @@ let rec matcher_variant_const lab p rem = match p.pat_desc with let make_variant_matching_constant p lab def ctx = function [] -> fatal_error "Matching.make_variant_matching_constant" - | ((arg, mut) :: argl) -> + | (_ :: argl) -> let def = make_default (matcher_variant_const lab) def and ctx = filter_ctx p ctx in {pm={ cases = []; args = argl ; default=def} ; @@ -1403,11 +1404,11 @@ let matcher_variant_nonconst lab p rem = match p.pat_desc with let make_variant_matching_nonconst p lab def ctx = function [] -> fatal_error "Matching.make_variant_matching_nonconst" - | ((arg, mut) :: argl) -> + | ((arg, _mut) :: argl) -> let def = make_default (matcher_variant_nonconst lab) def and ctx = filter_ctx p ctx in {pm= - {cases = []; args = (Lprim(Pfield 1, [arg]), Alias) :: argl; + {cases = []; args = (Lprim(Pfield 1, [arg], p.pat_loc), Alias) :: argl; default=def} ; ctx=ctx ; pat = normalize_pat p} @@ -1431,7 +1432,7 @@ let divide_variant row ctx {cases = cl; args = al; default=def} = add (make_variant_matching_nonconst p lab def ctx) variants (=) (Cstr_block tag) (pat :: patl, action) al end - | cl -> [] + | _ -> [] in divide cl @@ -1486,7 +1487,9 @@ let get_mod_field modname field = with Not_found -> fatal_error ("Primitive "^modname^"."^field^" not found.") in - Lprim(Pfield p, [Lprim(Pgetglobal mod_ident, [])]) + Lprim(Pfield p, + [Lprim(Pgetglobal mod_ident, [], Location.none)], + Location.none) with Not_found -> fatal_error ("Module "^modname^" unavailable.") ) @@ -1509,17 +1512,19 @@ let inline_lazy_force_cond arg loc = let varg = Lvar idarg in let tag = Ident.create "tag" in let force_fun = Lazy.force code_force_lazy_block in - Llet(Strict, idarg, arg, - Llet(Alias, tag, Lprim(Pccall prim_obj_tag, [varg]), + Llet(Strict, Pgenval, idarg, arg, + Llet(Alias, Pgenval, tag, Lprim(Pccall prim_obj_tag, [varg], loc), Lifthenelse( (* if (tag == Obj.forward_tag) then varg.(0) else ... *) Lprim(Pintcomp Ceq, - [Lvar tag; Lconst(Const_base(Const_int Obj.forward_tag))]), - Lprim(Pfield 0, [varg]), + [Lvar tag; Lconst(Const_base(Const_int Obj.forward_tag))], + loc), + Lprim(Pfield 0, [varg], loc), Lifthenelse( (* ... if (tag == Obj.lazy_tag) then Lazy.force varg else ... *) Lprim(Pintcomp Ceq, - [Lvar tag; Lconst(Const_base(Const_int Obj.lazy_tag))]), + [Lvar tag; Lconst(Const_base(Const_int Obj.lazy_tag))], + loc), Lapply{ap_should_be_tailcall=false; ap_loc=loc; ap_func=force_fun; @@ -1533,15 +1538,15 @@ let inline_lazy_force_switch arg loc = let idarg = Ident.create "lzarg" in let varg = Lvar idarg in let force_fun = Lazy.force code_force_lazy_block in - Llet(Strict, idarg, arg, + Llet(Strict, Pgenval, idarg, arg, Lifthenelse( - Lprim(Pisint, [varg]), varg, + Lprim(Pisint, [varg], loc), varg, (Lswitch (varg, { sw_numconsts = 0; sw_consts = []; sw_numblocks = 256; (* PR#6033 - tag ranges from 0 to 255 *) sw_blocks = - [ (Obj.forward_tag, Lprim(Pfield 0, [varg])); + [ (Obj.forward_tag, Lprim(Pfield 0, [varg], loc)); (Obj.lazy_tag, Lapply{ap_should_be_tailcall=false; ap_loc=loc; @@ -1562,7 +1567,7 @@ let inline_lazy_force arg loc = let make_lazy_matching def = function [] -> fatal_error "Matching.make_lazy_matching" - | (arg,mut) :: argl -> + | (arg,_mut) :: argl -> { cases = []; args = (inline_lazy_force arg Location.none, Strict) :: argl; @@ -1589,13 +1594,13 @@ let matcher_tuple arity p rem = match p.pat_desc with | Tpat_var _ -> get_args_tuple arity omega rem | _ -> get_args_tuple arity p rem -let make_tuple_matching arity def = function +let make_tuple_matching loc arity def = function [] -> fatal_error "Matching.make_tuple_matching" - | (arg, mut) :: argl -> + | (arg, _mut) :: argl -> let rec make_args pos = if pos >= arity then argl - else (Lprim(Pfield pos, [arg]), Alias) :: make_args (pos + 1) in + else (Lprim(Pfield pos, [arg], loc), Alias) :: make_args (pos + 1) in {cases = []; args = make_args 0 ; default=make_default (matcher_tuple arity) def} @@ -1603,7 +1608,7 @@ let make_tuple_matching arity def = function let divide_tuple arity p ctx pm = divide_line (filter_ctx p) - (make_tuple_matching arity) + (make_tuple_matching p.pat_loc arity) (get_args_tuple arity) p ctx pm (* Matching against a record pattern *) @@ -1626,23 +1631,25 @@ let matcher_record num_fields p rem = match p.pat_desc with | Tpat_var _ -> get_args_record num_fields omega rem | _ -> get_args_record num_fields p rem -let make_record_matching all_labels def = function +let make_record_matching loc all_labels def = function [] -> fatal_error "Matching.make_record_matching" - | ((arg, mut) :: argl) -> + | ((arg, _mut) :: argl) -> let rec make_args pos = if pos >= Array.length all_labels then argl else begin let lbl = all_labels.(pos) in let access = match lbl.lbl_repres with - Record_regular | Record_inlined _ -> Pfield lbl.lbl_pos - | Record_float -> Pfloatfield lbl.lbl_pos - | Record_extension -> Pfield (lbl.lbl_pos + 1) + | Record_regular | Record_inlined _ -> + Lprim (Pfield lbl.lbl_pos, [arg], loc) + | Record_unboxed _ -> arg + | Record_float -> Lprim (Pfloatfield lbl.lbl_pos, [arg], loc) + | Record_extension -> Lprim (Pfield (lbl.lbl_pos + 1), [arg], loc) in let str = match lbl.lbl_mut with Immutable -> Alias | Mutable -> StrictOpt in - (Lprim(access, [arg]), str) :: make_args(pos + 1) + (access, str) :: make_args(pos + 1) end in let nfields = Array.length all_labels in let def= make_default (matcher_record nfields) def in @@ -1653,7 +1660,7 @@ let divide_record all_labels p ctx pm = let get_args = get_args_record (Array.length all_labels) in divide_line (filter_ctx p) - (make_record_matching all_labels) + (make_record_matching p.pat_loc all_labels) get_args p ctx pm @@ -1675,12 +1682,14 @@ let matcher_array len p rem = match p.pat_desc with let make_array_matching kind p def ctx = function | [] -> fatal_error "Matching.make_array_matching" - | ((arg, mut) :: argl) -> + | ((arg, _mut) :: argl) -> let len = get_key_array p in let rec make_args pos = if pos >= len then argl - else (Lprim(Parrayrefu kind, [arg; Lconst(Const_base(Const_int pos))]), + else (Lprim(Parrayrefu kind, + [arg; Lconst(Const_base(Const_int pos))], + p.pat_loc), StrictOpt) :: make_args (pos + 1) in let def = make_default (matcher_array len) def and ctx = filter_ctx p ctx in @@ -1726,12 +1735,12 @@ let bind_sw arg k = match arg with | Lvar _ -> k arg | _ -> let id = Ident.create "switch" in - Llet (Strict,id,arg,k (Lvar id)) + Llet (Strict,Pgenval,id,arg,k (Lvar id)) (* Sequential equality tests *) -let make_string_test_sequence arg sw d = +let make_string_test_sequence loc arg sw d = let d,sw = match d with | None -> begin match sw with @@ -1746,7 +1755,7 @@ let make_string_test_sequence arg sw d = Lifthenelse (Lprim (prim_string_notequal, - [arg; Lconst (Const_immstring s)]), + [arg; Lconst (Const_immstring s)], loc), k,lam)) sw d) @@ -1760,40 +1769,40 @@ let rec split k xs = match xs with let zero_lam = Lconst (Const_base (Const_int 0)) -let tree_way_test arg lt eq gt = +let tree_way_test loc arg lt eq gt = Lifthenelse - (Lprim (Pintcomp Clt,[arg;zero_lam]),lt, - Lifthenelse(Lprim (Pintcomp Clt,[zero_lam;arg]),gt,eq)) + (Lprim (Pintcomp Clt,[arg;zero_lam], loc),lt, + Lifthenelse(Lprim (Pintcomp Clt,[zero_lam;arg], loc),gt,eq)) (* Dichotomic tree *) -let rec do_make_string_test_tree arg sw delta d = +let rec do_make_string_test_tree loc arg sw delta d = let len = List.length sw in if len <= strings_test_threshold+delta then - make_string_test_sequence arg sw d + make_string_test_sequence loc arg sw d else let lt,(s,act),gt = split len sw in bind_sw (Lprim (prim_string_compare, - [arg; Lconst (Const_immstring s)];)) + [arg; Lconst (Const_immstring s)], loc;)) (fun r -> - tree_way_test r - (do_make_string_test_tree arg lt delta d) + tree_way_test loc r + (do_make_string_test_tree loc arg lt delta d) act - (do_make_string_test_tree arg gt delta d)) + (do_make_string_test_tree loc arg gt delta d)) (* Entry point *) -let expand_stringswitch arg sw d = match d with +let expand_stringswitch loc arg sw d = match d with | None -> bind_sw arg - (fun arg -> do_make_string_test_tree arg sw 0 None) + (fun arg -> do_make_string_test_tree loc arg sw 0 None) | Some e -> bind_sw arg (fun arg -> make_catch e - (fun d -> do_make_string_test_tree arg sw 1 (Some d))) + (fun d -> do_make_string_test_tree loc arg sw 1 (Some d))) (**********************) (* Generic test trees *) @@ -1857,24 +1866,24 @@ let rec cut n l = [] -> raise (Invalid_argument "cut") | a::l -> let l1,l2 = cut (n-1) l in a::l1, l2 -let rec do_tests_fail fail tst arg = function +let rec do_tests_fail loc fail tst arg = function | [] -> fail | (c, act)::rem -> Lifthenelse - (Lprim (tst, [arg ; Lconst (Const_base c)]), - do_tests_fail fail tst arg rem, + (Lprim (tst, [arg ; Lconst (Const_base c)], loc), + do_tests_fail loc fail tst arg rem, act) -let rec do_tests_nofail tst arg = function +let rec do_tests_nofail loc tst arg = function | [] -> fatal_error "Matching.do_tests_nofail" | [_,act] -> act | (c,act)::rem -> Lifthenelse - (Lprim (tst, [arg ; Lconst (Const_base c)]), - do_tests_nofail tst arg rem, + (Lprim (tst, [arg ; Lconst (Const_base c)], loc), + do_tests_nofail loc tst arg rem, act) -let make_test_sequence fail tst lt_tst arg const_lambda_list = +let make_test_sequence loc fail tst lt_tst arg const_lambda_list = let const_lambda_list = sort_lambda_list const_lambda_list in let hs,const_lambda_list,fail = share_actions_tree const_lambda_list fail in @@ -1883,13 +1892,15 @@ let make_test_sequence fail tst lt_tst arg const_lambda_list = if List.length const_lambda_list >= 4 && lt_tst <> Pignore then split_sequence const_lambda_list else match fail with - | None -> do_tests_nofail tst arg const_lambda_list - | Some fail -> do_tests_fail fail tst arg const_lambda_list + | None -> do_tests_nofail loc tst arg const_lambda_list + | Some fail -> do_tests_fail loc fail tst arg const_lambda_list and split_sequence const_lambda_list = let list1, list2 = cut (List.length const_lambda_list / 2) const_lambda_list in - Lifthenelse(Lprim(lt_tst,[arg; Lconst(Const_base (fst(List.hd list2)))]), + Lifthenelse(Lprim(lt_tst, + [arg; Lconst(Const_base (fst(List.hd list2)))], + loc), make_test_sequence list1, make_test_sequence list2) in hs (make_test_sequence const_lambda_list) @@ -1907,10 +1918,10 @@ module SArg = struct type act = Lambda.lambda - let make_prim p args = Lprim (p,args) + let make_prim p args = Lprim (p,args,Location.none) let make_offset arg n = match n with | 0 -> arg - | _ -> Lprim (Poffsetint n,[arg]) + | _ -> Lprim (Poffsetint n,[arg],Location.none) let bind arg body = let newvar,newarg = match arg with @@ -1920,8 +1931,8 @@ module SArg = struct newvar,Lvar newvar in bind Alias newvar arg (body newarg) let make_const i = Lconst (Const_base (Const_int i)) - let make_isout h arg = Lprim (Pisout, [h ; arg]) - let make_isin h arg = Lprim (Pnot,[make_isout h arg]) + let make_isout h arg = Lprim (Pisout, [h ; arg],Location.none) + let make_isin h arg = Lprim (Pnot,[make_isout h arg],Location.none) let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) let make_switch arg cases acts = let l = ref [] in @@ -2018,7 +2029,7 @@ let get_edges low high l = match l with let as_interval_canfail fail low high l = let store = StoreExp.mk_store () in - let do_store tag act = + let do_store _tag act = let i = store.act_store act in (* @@ -2188,7 +2199,7 @@ let mk_failaction_pos partial seen ctx defs = | _,(pss,idef)::rem -> let now, later = List.partition - (fun (p,p_ctx) -> ctx_match p_ctx pss) to_test in + (fun (_p,p_ctx) -> ctx_match p_ctx pss) to_test in match now with | [] -> scan_def env to_test rem | _ -> scan_def ((List.map fst now,idef)::env) later rem in @@ -2218,8 +2229,8 @@ let mk_failaction_pos partial seen ctx defs = fail,[],jumps end -let combine_constant arg cst partial ctx def - (const_lambda_list, total, pats) = +let combine_constant loc arg cst partial ctx def + (const_lambda_list, total, _pats) = let fail, local_jumps = mk_failaction_neg partial ctx def in let lambda1 = @@ -2248,24 +2259,24 @@ let combine_constant arg cst partial ctx def | _ -> assert false) const_lambda_list in let hs,sw,fail = share_actions_tree sw fail in - hs (Lstringswitch (arg,sw,fail)) + hs (Lstringswitch (arg,sw,fail,loc)) | Const_float _ -> - make_test_sequence + make_test_sequence loc fail (Pfloatcomp Cneq) (Pfloatcomp Clt) arg const_lambda_list | Const_int32 _ -> - make_test_sequence + make_test_sequence loc fail (Pbintcomp(Pint32, Cneq)) (Pbintcomp(Pint32, Clt)) arg const_lambda_list | Const_int64 _ -> - make_test_sequence + make_test_sequence loc fail (Pbintcomp(Pint64, Cneq)) (Pbintcomp(Pint64, Clt)) arg const_lambda_list | Const_nativeint _ -> - make_test_sequence + make_test_sequence loc fail (Pbintcomp(Pnativeint, Cneq)) (Pbintcomp(Pnativeint, Clt)) arg const_lambda_list @@ -2281,7 +2292,8 @@ let split_cases tag_lambda_list = match cstr with Cstr_constant n -> ((n, act) :: consts, nonconsts) | Cstr_block n -> (consts, (n, act) :: nonconsts) - | _ -> assert false in + | Cstr_unboxed -> (consts, (0, act) :: nonconsts) + | Cstr_extension _ -> assert false in let const, nonconst = split_rec tag_lambda_list in sort_int_lambda_list const, sort_int_lambda_list nonconst @@ -2298,7 +2310,7 @@ let split_extension_cases tag_lambda_list = split_rec tag_lambda_list -let combine_constructor arg ex_pat cstr partial ctx def +let combine_constructor loc arg ex_pat cstr partial ctx def (tag_lambda_list, total1, pats) = if cstr.cstr_consts < 0 then begin (* Special cases for extensions *) @@ -2325,17 +2337,17 @@ let combine_constructor arg ex_pat cstr partial ctx def (fun (path, act) rem -> Lifthenelse(Lprim(Pintcomp Ceq, [Lvar tag; - transl_path ex_pat.pat_env path]), + transl_path ex_pat.pat_env path], loc), act, rem)) nonconsts default in - Llet(Alias, tag, Lprim(Pfield 0, [arg]), tests) + Llet(Alias, Pgenval,tag, Lprim(Pfield 0, [arg], loc), tests) in List.fold_right (fun (path, act) rem -> Lifthenelse(Lprim(Pintcomp Ceq, - [arg; transl_path ex_pat.pat_env path]), + [arg; transl_path ex_pat.pat_env path], loc), act, rem)) consts nonconst_lambda @@ -2379,7 +2391,7 @@ let combine_constructor arg ex_pat cstr partial ctx def match act0 with | Some act -> Lifthenelse - (Lprim (Pisint, [arg]), + (Lprim (Pisint, [arg], loc), call_switcher fail_opt arg 0 (n-1) consts, @@ -2405,13 +2417,14 @@ let call_switcher_variant_constant fail arg int_lambda_list = call_switcher fail arg min_int max_int int_lambda_list -let call_switcher_variant_constr fail arg int_lambda_list = +let call_switcher_variant_constr loc fail arg int_lambda_list = let v = Ident.create "variant" in - Llet(Alias, v, Lprim(Pfield 0, [arg]), + Llet(Alias, Pgenval, v, Lprim(Pfield 0, [arg], loc), call_switcher fail (Lvar v) min_int max_int int_lambda_list) -let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) = +let combine_variant loc row arg partial ctx def + (tag_lambda_list, total1, _pats) = let row = Btype.row_repr row in let num_constr = ref 0 in if row.row_closed then @@ -2424,7 +2437,7 @@ let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) = else num_constr := max_int; let test_int_or_block arg if_int if_block = - Lifthenelse(Lprim (Pisint, [arg]), if_int, if_block) in + Lifthenelse(Lprim (Pisint, [arg], loc), if_int, if_block) in let sig_complete = List.length tag_lambda_list = !num_constr and one_action = same_actions tag_lambda_list in let fail, local_jumps = @@ -2439,12 +2452,12 @@ let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) = | None, Some act -> act | _,_ -> match (consts, nonconsts) with - | ([n, act1], [m, act2]) when fail=None -> + | ([_, act1], [_, act2]) when fail=None -> test_int_or_block arg act1 act2 | (_, []) -> (* One can compare integers and pointers *) make_test_sequence_variant_constant fail arg consts | ([], _) -> - let lam = call_switcher_variant_constr + let lam = call_switcher_variant_constr loc fail arg nonconsts in (* One must not dereference integers *) begin match fail with @@ -2456,15 +2469,15 @@ let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) = call_switcher_variant_constant fail arg consts and lam_nonconst = - call_switcher_variant_constr + call_switcher_variant_constr loc fail arg nonconsts in test_int_or_block arg lam_const lam_nonconst in lambda1, jumps_union local_jumps total1 -let combine_array arg kind partial ctx def - (len_lambda_list, total1, pats) = +let combine_array loc arg kind partial ctx def + (len_lambda_list, total1, _pats) = let fail, local_jumps = mk_failaction_neg partial ctx def in let lambda1 = let newvar = Ident.create "len" in @@ -2473,7 +2486,7 @@ let combine_array arg kind partial ctx def fail (Lvar newvar) 0 max_int len_lambda_list in bind - Alias newvar (Lprim(Parraylength kind, [arg])) switch in + Alias newvar (Lprim(Parraylength kind, [arg], loc)) switch in lambda1, jumps_union local_jumps total1 (* Insertion of debugging events *) @@ -2488,10 +2501,10 @@ let rec event_branch repr lam = lev_kind = ev.lev_kind; lev_repr = repr; lev_env = ev.lev_env}) - | (Llet(str, id, lam, body), _) -> - Llet(str, id, lam, event_branch repr body) + | (Llet(str, k, id, lam, body), _) -> + Llet(str, k, id, lam, event_branch repr body) | Lstaticraise _,_ -> lam - | (_, Some r) -> + | (_, Some _) -> Printlambda.lambda Format.str_formatter lam ; fatal_error ("Matching.event_branch: "^Format.flush_str_formatter ()) @@ -2581,9 +2594,9 @@ let rec approx_present v = function | Lconst _ -> false | Lstaticraise (_,args) -> List.exists (fun lam -> approx_present v lam) args - | Lprim (_,args) -> + | Lprim (_,args,_) -> List.exists (fun lam -> approx_present v lam) args - | Llet (Alias, _, l1, l2) -> + | Llet (Alias, _k, _, l1, l2) -> approx_present v l1 || approx_present v l2 | Lvar vv -> Ident.same v vv | _ -> true @@ -2607,11 +2620,11 @@ let rec lower_bind v arg lam = match lam with | Lswitch (ls,({sw_consts=[] ; sw_blocks = [i,act]} as sw)) when not (approx_present v ls) -> Lswitch (ls, {sw with sw_blocks = [i,lower_bind v arg act]}) -| Llet (Alias, vv, lv, l) -> +| Llet (Alias, k, vv, lv, l) -> if approx_present v lv then bind Alias v arg lam else - Llet (Alias, vv, lv, lower_bind v arg l) + Llet (Alias, k, vv, lv, lower_bind v arg l) | _ -> bind Alias v arg lam @@ -2663,10 +2676,10 @@ let rec comp_match_handlers comp_fun partial ctx arg first_match next_matchs = (* To find reasonable names for variables *) let rec name_pattern default = function - (pat :: patl, action) :: rem -> + (pat :: _, _) :: rem -> begin match pat.pat_desc with Tpat_var (id, _) -> id - | Tpat_alias(p, id, _) -> id + | Tpat_alias(_, id, _) -> id | _ -> name_pattern default rem end | _ -> Ident.create default @@ -2744,26 +2757,27 @@ and do_compile_matching repr partial ctx arg pmh = match pmh with compile_test (compile_match repr partial) partial divide_constant - (combine_constant arg cst partial) + (combine_constant pat.pat_loc arg cst partial) ctx pm | Tpat_construct (_, cstr, _) -> compile_test (compile_match repr partial) partial - divide_constructor (combine_constructor arg pat cstr partial) + divide_constructor + (combine_constructor pat.pat_loc arg pat cstr partial) ctx pm | Tpat_array _ -> let kind = Typeopt.array_pattern_kind pat in compile_test (compile_match repr partial) partial - (divide_array kind) (combine_array arg kind partial) + (divide_array kind) (combine_array pat.pat_loc arg kind partial) ctx pm | Tpat_lazy _ -> compile_no_test (divide_lazy (normalize_pat pat)) ctx_combine repr partial ctx pm - | Tpat_variant(lab, _, row) -> + | Tpat_variant(_, _, row) -> compile_test (compile_match repr partial) partial (divide_variant !row) - (combine_variant !row arg partial) + (combine_variant pat.pat_loc !row arg partial) ctx pm | _ -> assert false end @@ -2879,7 +2893,7 @@ let check_total total lambda i handler_fun = Lstaticcatch(lambda, (i,[]), handler_fun()) end -let compile_matching loc repr handler_fun arg pat_act_list partial = +let compile_matching repr handler_fun arg pat_act_list partial = let partial = check_partial pat_act_list partial in match partial with | Partial -> @@ -2907,24 +2921,24 @@ let compile_matching loc repr handler_fun arg pat_act_list partial = let partial_function loc () = (* [Location.get_pos_info] is too expensive *) let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in - Lprim(Praise Raise_regular, [Lprim(Pmakeblock(0, Immutable), + Lprim(Praise Raise_regular, [Lprim(Pmakeblock(0, Immutable, None), [transl_normal_path Predef.path_match_failure; Lconst(Const_block(0, [Const_base(Const_string (fname, None)); Const_base(Const_int line); - Const_base(Const_int char)]))])]) + Const_base(Const_int char)]))], loc)], loc) let for_function loc repr param pat_act_list partial = - compile_matching loc repr (partial_function loc) param pat_act_list partial + compile_matching repr (partial_function loc) param pat_act_list partial (* In the following two cases, exhaustiveness info is not available! *) let for_trywith param pat_act_list = - compile_matching Location.none None - (fun () -> Lprim(Praise Raise_reraise, [param])) + compile_matching None + (fun () -> Lprim(Praise Raise_reraise, [param], Location.none)) param pat_act_list Partial let simple_for_let loc param pat body = - compile_matching loc None (partial_function loc) param [pat, body] Partial + compile_matching None (partial_function loc) param [pat, body] Partial (* Optimize binding of immediate tuples @@ -2976,7 +2990,7 @@ let simple_for_let loc param pat body = *) let rec map_return f = function - | Llet (k, id, l1, l2) -> Llet (k, id, l1, map_return f l2) + | Llet (str, k, id, l1, l2) -> Llet (str, k, id, l1, map_return f l2) | Lletrec (l1, l2) -> Lletrec (l1, map_return f l2) | Lifthenelse (lcond, lthen, lelse) -> Lifthenelse (lcond, map_return f lthen, map_return f lelse) @@ -2985,7 +2999,7 @@ let rec map_return f = function | Ltrywith (l1, id, l2) -> Ltrywith (map_return f l1, id, map_return f l2) | Lstaticcatch (l1, b, l2) -> Lstaticcatch (map_return f l1, b, map_return f l2) - | Lstaticraise _ | Lprim(Praise _, _) as l -> l + | Lstaticraise _ | Lprim(Praise _, _, _) as l -> l | l -> f l (* The 'opt' reference indicates if the optimization is worthy. @@ -3005,7 +3019,7 @@ let rec map_return f = function let assign_pat opt nraise catch_ids loc pat lam = let rec collect acc pat lam = match pat.pat_desc, lam with - | Tpat_tuple patl, Lprim(Pmakeblock _, lams) -> + | Tpat_tuple patl, Lprim(Pmakeblock _, lams, _) -> opt := true; List.fold_left2 collect acc patl lams | Tpat_tuple patl, Lconst(Const_block(_, scl)) -> @@ -3043,9 +3057,10 @@ let for_let loc param pat body = (* This eliminates a useless variable (and stack slot in bytecode) for "let _ = ...". See #6865. *) Lsequence(param, body) - | Tpat_var _ -> - (* fast path *) - simple_for_let loc param pat body + | Tpat_var (id, _) -> + (* fast path, and keep track of simple bindings to unboxable numbers *) + let k = Typeopt.value_kind pat.pat_env pat.pat_type in + Llet(Strict, k, id, param, body) | _ -> let opt = ref false in let nraise = next_raise_count () in @@ -3146,12 +3161,12 @@ let do_for_multiple_match loc paraml pat_act_list partial = let raise_num = next_raise_count () in raise_num, { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [Lprim(Pmakeblock(0, Immutable), paraml), Strict] ; + args = [Lprim(Pmakeblock(0, Immutable, None), paraml, loc), Strict]; default = [[[omega]],raise_num] } | _ -> -1, { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [Lprim(Pmakeblock(0, Immutable), paraml), Strict] ; + args = [Lprim(Pmakeblock(0, Immutable, None), paraml, loc), Strict]; default = [] } in try diff --git a/bytecomp/matching.mli b/bytecomp/matching.mli index 916479a8..f29901bd 100644 --- a/bytecomp/matching.mli +++ b/bytecomp/matching.mli @@ -41,6 +41,6 @@ val flatten_pattern: int -> pattern -> pattern list (* Expand stringswitch to string test tree *) val expand_stringswitch: - lambda -> (string * lambda) list -> lambda option -> lambda + Location.t -> lambda -> (string * lambda) list -> lambda option -> lambda val inline_lazy_force : lambda -> Location.t -> lambda diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index fb7bdc00..94513920 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -54,6 +54,18 @@ let boxed_integer_name = function | Pint32 -> "int32" | Pint64 -> "int64" +let value_kind = function + | Pgenval -> "" + | Pintval -> "[int]" + | Pfloatval -> "[float]" + | Pboxedintval bi -> Printf.sprintf "[%s]" (boxed_integer_name bi) + +let field_kind = function + | Pgenval -> "*" + | Pintval -> "int" + | Pfloatval -> "float" + | Pboxedintval bi -> boxed_integer_name bi + let print_boxed_integer_conversion ppf bi1 bi2 = fprintf ppf "%s_of_%s" (boxed_integer_name bi2) (boxed_integer_name bi1) @@ -91,6 +103,8 @@ let record_rep ppf r = match r with | Record_regular -> fprintf ppf "regular" | Record_inlined i -> fprintf ppf "inlined(%i)" i + | Record_unboxed false -> fprintf ppf "unboxed" + | Record_unboxed true -> fprintf ppf "inlined(unboxed)" | Record_float -> fprintf ppf "float" | Record_extension -> fprintf ppf "ext" ;; @@ -102,16 +116,32 @@ let string_of_loc_kind = function | Loc_POS -> "loc_POS" | Loc_LOC -> "loc_LOC" +let block_shape ppf shape = match shape with + | None | Some [] -> () + | Some l when List.for_all ((=) Pgenval) l -> () + | Some [elt] -> + Format.fprintf ppf " (%s)" (field_kind elt) + | Some (h :: t) -> + Format.fprintf ppf " (%s" (field_kind h); + List.iter (fun elt -> + Format.fprintf ppf ",%s" (field_kind elt)) + t; + Format.fprintf ppf ")" + let primitive ppf = function | Pidentity -> fprintf ppf "id" + | Pbytes_to_string -> fprintf ppf "bytes_to_string" + | Pbytes_of_string -> fprintf ppf "bytes_of_string" | Pignore -> fprintf ppf "ignore" - | Prevapply _ -> fprintf ppf "revapply" - | Pdirapply _ -> fprintf ppf "dirapply" + | Prevapply -> fprintf ppf "revapply" + | Pdirapply -> fprintf ppf "dirapply" | Ploc kind -> fprintf ppf "%s" (string_of_loc_kind kind) | Pgetglobal id -> fprintf ppf "global %a" Ident.print id | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id - | Pmakeblock(tag, Immutable) -> fprintf ppf "makeblock %i" tag - | Pmakeblock(tag, Mutable) -> fprintf ppf "makemutable %i" tag + | Pmakeblock(tag, Immutable, shape) -> + fprintf ppf "makeblock %i%a" tag block_shape shape + | Pmakeblock(tag, Mutable, shape) -> + fprintf ppf "makemutable %i%a" tag block_shape shape | Pfield n -> fprintf ppf "field %i" n | Psetfield(n, ptr, init) -> let instr = @@ -144,8 +174,10 @@ let primitive ppf = function | Paddint -> fprintf ppf "+" | Psubint -> fprintf ppf "-" | Pmulint -> fprintf ppf "*" - | Pdivint -> fprintf ppf "/" - | Pmodint -> fprintf ppf "mod" + | Pdivint Safe -> fprintf ppf "/" + | Pdivint Unsafe -> fprintf ppf "/u" + | Pmodint Safe -> fprintf ppf "mod" + | Pmodint Unsafe -> fprintf ppf "mod_unsafe" | Pandint -> fprintf ppf "and" | Porint -> fprintf ppf "or" | Pxorint -> fprintf ppf "xor" @@ -176,9 +208,13 @@ let primitive ppf = function | Pfloatcomp(Cge) -> fprintf ppf ">=." | Pstringlength -> fprintf ppf "string.length" | Pstringrefu -> fprintf ppf "string.unsafe_get" - | Pstringsetu -> fprintf ppf "string.unsafe_set" | Pstringrefs -> fprintf ppf "string.get" - | Pstringsets -> fprintf ppf "string.set" + | Pbyteslength -> fprintf ppf "bytes.length" + | Pbytesrefu -> fprintf ppf "bytes.unsafe_get" + | Pbytessetu -> fprintf ppf "bytes.unsafe_set" + | Pbytesrefs -> fprintf ppf "bytes.get" + | Pbytessets -> fprintf ppf "bytes.set" + | Parraylength k -> fprintf ppf "array.length[%s]" (array_kind k) | Pmakearray (k, Mutable) -> fprintf ppf "makearray[%s]" (array_kind k) | Pmakearray (k, Immutable) -> fprintf ppf "makearray_imm[%s]" (array_kind k) @@ -196,7 +232,8 @@ let primitive ppf = function | Max_wosize -> "max_wosize" | Ostype_unix -> "ostype_unix" | Ostype_win32 -> "ostype_win32" - | Ostype_cygwin -> "ostype_cygwin" in + | Ostype_cygwin -> "ostype_cygwin" + | Backend_type -> "backend_type" in fprintf ppf "sys.constant_%s" const_name | Pisint -> fprintf ppf "isint" | Pisout -> fprintf ppf "isout" @@ -208,8 +245,14 @@ let primitive ppf = function | Paddbint bi -> print_boxed_integer "add" ppf bi | Psubbint bi -> print_boxed_integer "sub" ppf bi | Pmulbint bi -> print_boxed_integer "mul" ppf bi - | Pdivbint bi -> print_boxed_integer "div" ppf bi - | Pmodbint bi -> print_boxed_integer "mod" ppf bi + | Pdivbint { size = bi; is_safe = Safe } -> + print_boxed_integer "div" ppf bi + | Pdivbint { size = bi; is_safe = Unsafe } -> + print_boxed_integer "div_unsafe" ppf bi + | Pmodbint { size = bi; is_safe = Safe } -> + print_boxed_integer "mod" ppf bi + | Pmodbint { size = bi; is_safe = Unsafe } -> + print_boxed_integer "mod_unsafe" ppf bi | Pandbint bi -> print_boxed_integer "and" ppf bi | Porbint bi -> print_boxed_integer "or" ppf bi | Pxorbint bi -> print_boxed_integer "xor" ppf bi @@ -222,9 +265,9 @@ let primitive ppf = function | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi | Pbintcomp(bi, Cge) -> print_boxed_integer ">=" ppf bi - | Pbigarrayref(unsafe, n, kind, layout) -> + | Pbigarrayref(unsafe, _n, kind, layout) -> print_bigarray "get" unsafe kind ppf layout - | Pbigarrayset(unsafe, n, kind, layout) -> + | Pbigarrayset(unsafe, _n, kind, layout) -> print_bigarray "set" unsafe kind ppf layout | Pbigarraydim(n) -> fprintf ppf "Bigarray.dim_%i" n | Pstring_load_16(unsafe) -> @@ -270,9 +313,11 @@ let primitive ppf = function let name_of_primitive = function | Pidentity -> "Pidentity" + | Pbytes_of_string -> "Pbytes_of_string" + | Pbytes_to_string -> "Pbytes_to_string" | Pignore -> "Pignore" - | Prevapply _ -> "Prevapply" - | Pdirapply _ -> "Pdirapply" + | Prevapply -> "Prevapply" + | Pdirapply -> "Pdirapply" | Ploc _ -> "Ploc" | Pgetglobal _ -> "Pgetglobal" | Psetglobal _ -> "Psetglobal" @@ -292,8 +337,8 @@ let name_of_primitive = function | Paddint -> "Paddint" | Psubint -> "Psubint" | Pmulint -> "Pmulint" - | Pdivint -> "Pdivint" - | Pmodint -> "Pmodint" + | Pdivint _ -> "Pdivint" + | Pmodint _ -> "Pmodint" | Pandint -> "Pandint" | Porint -> "Porint" | Pxorint -> "Pxorint" @@ -314,9 +359,12 @@ let name_of_primitive = function | Pfloatcomp _ -> "Pfloatcomp" | Pstringlength -> "Pstringlength" | Pstringrefu -> "Pstringrefu" - | Pstringsetu -> "Pstringsetu" | Pstringrefs -> "Pstringrefs" - | Pstringsets -> "Pstringsets" + | Pbyteslength -> "Pbyteslength" + | Pbytesrefu -> "Pbytesrefu" + | Pbytessetu -> "Pbytessetu" + | Pbytesrefs -> "Pbytesrefs" + | Pbytessets -> "Pbytessets" | Parraylength _ -> "Parraylength" | Pmakearray _ -> "Pmakearray" | Pduparray _ -> "Pduparray" @@ -422,16 +470,18 @@ let rec lam ppf = function fprintf ppf ")" in fprintf ppf "@[<2>(function%a@ %a%a)@]" pr_params params function_attribute attr lam body - | Llet(str, id, arg, body) -> + | Llet(str, k, id, arg, body) -> let kind = function - Alias -> "a" | Strict -> "" | StrictOpt -> "o" | Variable -> "v" in + Alias -> "a" | Strict -> "" | StrictOpt -> "o" | Variable -> "v" + in let rec letbody = function - | Llet(str, id, arg, body) -> - fprintf ppf "@ @[<2>%a =%s@ %a@]" Ident.print id (kind str) lam arg; + | Llet(str, k, id, arg, body) -> + fprintf ppf "@ @[<2>%a =%s%s@ %a@]" + Ident.print id (kind str) (value_kind k) lam arg; letbody body | expr -> expr in - fprintf ppf "@[<2>(let@ @[(@[<2>%a =%s@ %a@]" - Ident.print id (kind str) lam arg; + fprintf ppf "@[<2>(let@ @[(@[<2>%a =%s%s@ %a@]" + Ident.print id (kind str) (value_kind k) lam arg; let expr = letbody body in fprintf ppf ")@]@ %a)@]" lam expr | Lletrec(id_arg_list, body) -> @@ -444,7 +494,7 @@ let rec lam ppf = function id_arg_list in fprintf ppf "@[<2>(letrec@ (@[%a@])@ %a)@]" bindings id_arg_list lam body - | Lprim(prim, largs) -> + | Lprim(prim, largs, _) -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs @@ -471,7 +521,7 @@ let rec lam ppf = function "@[<1>(%s %a@ @[%a@])@]" (match sw.sw_failaction with None -> "switch*" | _ -> "switch") lam larg switch sw - | Lstringswitch(arg, cases, default) -> + | Lstringswitch(arg, cases, default, _) -> let switch ppf cases = let spc = ref false in List.iter diff --git a/bytecomp/printlambda.mli b/bytecomp/printlambda.mli index 7b81ce2d..daf0d81a 100644 --- a/bytecomp/printlambda.mli +++ b/bytecomp/printlambda.mli @@ -22,3 +22,4 @@ val lambda: formatter -> lambda -> unit val program: formatter -> program -> unit val primitive: formatter -> primitive -> unit val name_of_primitive : primitive -> string +val value_kind : value_kind -> string diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml index fe1d005b..4a66f71e 100644 --- a/bytecomp/simplif.ml +++ b/bytecomp/simplif.ml @@ -26,27 +26,27 @@ exception Real_reference let rec eliminate_ref id = function Lvar v as lam -> if Ident.same v id then raise Real_reference else lam - | Lconst cst as lam -> lam + | Lconst _ as lam -> lam | Lapply ap -> Lapply{ap with ap_func = eliminate_ref id ap.ap_func; ap_args = List.map (eliminate_ref id) ap.ap_args} - | Lfunction{kind; params; body} as lam -> + | Lfunction _ as lam -> if IdentSet.mem id (free_variables lam) then raise Real_reference else lam - | Llet(str, v, e1, e2) -> - Llet(str, v, eliminate_ref id e1, eliminate_ref id e2) + | Llet(str, kind, v, e1, e2) -> + Llet(str, kind, v, eliminate_ref id e1, eliminate_ref id e2) | Lletrec(idel, e2) -> Lletrec(List.map (fun (v, e) -> (v, eliminate_ref id e)) idel, eliminate_ref id e2) - | Lprim(Pfield 0, [Lvar v]) when Ident.same v id -> + | Lprim(Pfield 0, [Lvar v], _) when Ident.same v id -> Lvar id - | Lprim(Psetfield(0, _, _), [Lvar v; e]) when Ident.same v id -> + | Lprim(Psetfield(0, _, _), [Lvar v; e], _) when Ident.same v id -> Lassign(id, eliminate_ref id e) - | Lprim(Poffsetref delta, [Lvar v]) when Ident.same v id -> - Lassign(id, Lprim(Poffsetint delta, [Lvar id])) - | Lprim(p, el) -> - Lprim(p, List.map (eliminate_ref id) el) + | Lprim(Poffsetref delta, [Lvar v], loc) when Ident.same v id -> + Lassign(id, Lprim(Poffsetint delta, [Lvar id], loc)) + | Lprim(p, el, loc) -> + Lprim(p, List.map (eliminate_ref id) el, loc) | Lswitch(e, sw) -> Lswitch(eliminate_ref id e, {sw_numconsts = sw.sw_numconsts; @@ -57,11 +57,11 @@ let rec eliminate_ref id = function List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_blocks; sw_failaction = Misc.may_map (eliminate_ref id) sw.sw_failaction; }) - | Lstringswitch(e, sw, default) -> + | Lstringswitch(e, sw, default, loc) -> Lstringswitch (eliminate_ref id e, List.map (fun (s, e) -> (s, eliminate_ref id e)) sw, - Misc.may_map (eliminate_ref id) default) + Misc.may_map (eliminate_ref id) default, loc) | Lstaticraise (i,args) -> Lstaticraise (i,List.map (eliminate_ref id) args) | Lstaticcatch(e1, i, e2) -> @@ -111,19 +111,19 @@ let simplify_exits lam = let rec count = function | (Lvar _| Lconst _) -> () | Lapply ap -> count ap.ap_func; List.iter count ap.ap_args - | Lfunction{kind; params; body = l} -> count l - | Llet(str, v, l1, l2) -> + | Lfunction {body} -> count body + | Llet(_str, _kind, _v, l1, l2) -> count l2; count l1 | Lletrec(bindings, body) -> - List.iter (fun (v, l) -> count l) bindings; + List.iter (fun (_v, l) -> count l) bindings; count body - | Lprim(p, ll) -> List.iter count ll + | Lprim(_p, ll, _) -> List.iter count ll | Lswitch(l, sw) -> count_default sw ; count l; List.iter (fun (_, l) -> count l) sw.sw_consts; List.iter (fun (_, l) -> count l) sw.sw_blocks - | Lstringswitch(l, sw, d) -> + | Lstringswitch(l, sw, d, _) -> count l; List.iter (fun (_, l) -> count l) sw; begin match d with @@ -150,15 +150,15 @@ let simplify_exits lam = l2 will be removed, so don't count its exits *) if count_exit i > 0 then count l2 - | Ltrywith(l1, v, l2) -> count l1; count l2 + | Ltrywith(l1, _v, l2) -> count l1; count l2 | Lifthenelse(l1, l2, l3) -> count l1; count l2; count l3 | Lsequence(l1, l2) -> count l1; count l2 | Lwhile(l1, l2) -> count l1; count l2 - | Lfor(_, l1, l2, dir, l3) -> count l1; count l2; count l3 - | Lassign(v, l) -> count l - | Lsend(k, m, o, ll, _) -> List.iter count (m::o::ll) + | Lfor(_, l1, l2, _dir, l3) -> count l1; count l2; count l3 + | Lassign(_v, l) -> count l + | Lsend(_k, m, o, ll, _) -> List.iter count (m::o::ll) | Levent(l, _) -> count l - | Lifused(v, l) -> count l + | Lifused(_v, l) -> count l and count_default sw = match sw.sw_failaction with | None -> () @@ -200,37 +200,37 @@ let simplify_exits lam = | Lapply ap -> Lapply{ap with ap_func = simplif ap.ap_func; ap_args = List.map simplif ap.ap_args} - | Lfunction{kind; params; body = l; attr} -> - Lfunction{kind; params; body = simplif l; attr} - | Llet(kind, v, l1, l2) -> Llet(kind, v, simplif l1, simplif l2) + | Lfunction{kind; params; body = l; attr; loc} -> + Lfunction{kind; params; body = simplif l; attr; loc} + | Llet(str, kind, v, l1, l2) -> Llet(str, kind, v, simplif l1, simplif l2) | Lletrec(bindings, body) -> Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body) - | Lprim(p, ll) -> begin + | Lprim(p, ll, loc) -> begin let ll = List.map simplif ll in match p, ll with (* Simplify %revapply, for n-ary functions with n > 1 *) - | Prevapply loc, [x; Lapply ap] - | Prevapply loc, [x; Levent (Lapply ap,_)] -> + | Prevapply, [x; Lapply ap] + | Prevapply, [x; Levent (Lapply ap,_)] -> Lapply {ap with ap_args = ap.ap_args @ [x]; ap_loc = loc} - | Prevapply loc, [x; f] -> Lapply {ap_should_be_tailcall=false; - ap_loc=loc; - ap_func=f; - ap_args=[x]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise} + | Prevapply, [x; f] -> Lapply {ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=f; + ap_args=[x]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise} (* Simplify %apply, for n-ary functions with n > 1 *) - | Pdirapply loc, [Lapply ap; x] - | Pdirapply loc, [Levent (Lapply ap,_); x] -> + | Pdirapply, [Lapply ap; x] + | Pdirapply, [Levent (Lapply ap,_); x] -> Lapply {ap with ap_args = ap.ap_args @ [x]; ap_loc = loc} - | Pdirapply loc, [f; x] -> Lapply {ap_should_be_tailcall=false; - ap_loc=loc; - ap_func=f; - ap_args=[x]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise} - - | _ -> Lprim(p, ll) + | Pdirapply, [f; x] -> Lapply {ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=f; + ap_args=[x]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise} + + | _ -> Lprim(p, ll, loc) end | Lswitch(l, sw) -> let new_l = simplif l @@ -241,10 +241,10 @@ let simplify_exits lam = (new_l, {sw with sw_consts = new_consts ; sw_blocks = new_blocks; sw_failaction = new_fail}) - | Lstringswitch(l,sw,d) -> + | Lstringswitch(l,sw,d,loc) -> Lstringswitch (simplif l,List.map (fun (s,l) -> s,simplif l) sw, - Misc.may_map simplif d) + Misc.may_map simplif d,loc) | Lstaticraise (i,[]) as l -> begin try let _,handler = Hashtbl.find subst i in @@ -262,12 +262,12 @@ let simplify_exits lam = (fun x y t -> Ident.add x (Lvar y) t) xs ys Ident.empty in List.fold_right2 - (fun y l r -> Llet (Alias, y, l, r)) + (fun y l r -> Llet (Alias, Pgenval, y, l, r)) ys ls (Lambda.subst_lambda env handler) with | Not_found -> Lstaticraise (i,ls) end - | Lstaticcatch (l1,(i,[]),(Lstaticraise (j,[]) as l2)) -> + | Lstaticcatch (l1,(i,[]),(Lstaticraise (_j,[]) as l2)) -> Hashtbl.add subst i ([],simplif l2) ; simplif l1 | Lstaticcatch (l1,(i,xs),l2) -> @@ -302,7 +302,7 @@ let simplify_exits lam = *) let beta_reduce params body args = - List.fold_left2 (fun l param arg -> Llet(Strict, param, arg, l)) + List.fold_left2 (fun l param arg -> Llet(Strict, Pgenval, param, arg, l)) body params args (* Simplification of lets *) @@ -352,39 +352,39 @@ let simplify_lets lam = () in let rec count bv = function - | Lconst cst -> () + | Lconst _ -> () | Lvar v -> use_var bv v 1 | Lapply{ap_func = Lfunction{kind = Curried; params; body}; ap_args = args} when optimize && List.length params = List.length args -> count bv (beta_reduce params body args) | Lapply{ap_func = Lfunction{kind = Tupled; params; body}; - ap_args = [Lprim(Pmakeblock _, args)]} + ap_args = [Lprim(Pmakeblock _, args, _)]} when optimize && List.length params = List.length args -> count bv (beta_reduce params body args) | Lapply{ap_func = l1; ap_args = ll} -> count bv l1; List.iter (count bv) ll - | Lfunction{kind; params; body = l} -> - count Tbl.empty l - | Llet(str, v, Lvar w, l2) when optimize -> + | Lfunction {body} -> + count Tbl.empty body + | Llet(_str, _k, v, Lvar w, l2) when optimize -> (* v will be replaced by w in l2, so each occurrence of v in l2 increases w's refcount *) count (bind_var bv v) l2; use_var bv w (count_var v) - | Llet(str, v, l1, l2) -> + | Llet(str, _kind, v, l1, l2) -> count (bind_var bv v) l2; (* If v is unused, l1 will be removed, so don't count its variables *) if str = Strict || count_var v > 0 then count bv l1 | Lletrec(bindings, body) -> - List.iter (fun (v, l) -> count bv l) bindings; + List.iter (fun (_v, l) -> count bv l) bindings; count bv body - | Lprim(p, ll) -> List.iter (count bv) ll + | Lprim(_p, ll, _) -> List.iter (count bv) ll | Lswitch(l, sw) -> count_default bv sw ; count bv l; List.iter (fun (_, l) -> count bv l) sw.sw_consts; List.iter (fun (_, l) -> count bv l) sw.sw_blocks - | Lstringswitch(l, sw, d) -> + | Lstringswitch(l, sw, d, _) -> count bv l ; List.iter (fun (_, l) -> count bv l) sw ; begin match d with @@ -395,14 +395,14 @@ let simplify_lets lam = end | None -> () end - | Lstaticraise (i,ls) -> List.iter (count bv) ls - | Lstaticcatch(l1, (i,_), l2) -> count bv l1; count bv l2 - | Ltrywith(l1, v, l2) -> count bv l1; count bv l2 + | Lstaticraise (_i,ls) -> List.iter (count bv) ls + | Lstaticcatch(l1, _, l2) -> count bv l1; count bv l2 + | Ltrywith(l1, _v, l2) -> count bv l1; count bv l2 | Lifthenelse(l1, l2, l3) -> count bv l1; count bv l2; count bv l3 | Lsequence(l1, l2) -> count bv l1; count bv l2 | Lwhile(l1, l2) -> count Tbl.empty l1; count Tbl.empty l2 - | Lfor(_, l1, l2, dir, l3) -> count bv l1; count bv l2; count Tbl.empty l3 - | Lassign(v, l) -> + | Lfor(_, l1, l2, _dir, l3) -> count bv l1; count bv l2; count Tbl.empty l3 + | Lassign(_v, l) -> (* Lalias-bound variables are never assigned, so don't increase v's refcount *) count bv l @@ -435,9 +435,9 @@ let simplify_lets lam = (* This (small) optimisation is always legal, it may uncover some tail call later on. *) - let mklet (kind,v,e1,e2) = match e2 with + let mklet str kind v e1 e2 = match e2 with | Lvar w when optimize && Ident.same v w -> e1 - | _ -> Llet (kind,v,e1,e2) in + | _ -> Llet (str, kind,v,e1,e2) in let rec simplif = function @@ -447,51 +447,57 @@ let simplify_lets lam = with Not_found -> l end - | Lconst cst as l -> l + | Lconst _ as l -> l | Lapply{ap_func = Lfunction{kind = Curried; params; body}; ap_args = args} when optimize && List.length params = List.length args -> simplif (beta_reduce params body args) | Lapply{ap_func = Lfunction{kind = Tupled; params; body}; - ap_args = [Lprim(Pmakeblock _, args)]} + ap_args = [Lprim(Pmakeblock _, args, _)]} when optimize && List.length params = List.length args -> simplif (beta_reduce params body args) | Lapply ap -> Lapply {ap with ap_func = simplif ap.ap_func; ap_args = List.map simplif ap.ap_args} - | Lfunction{kind; params; body = l; attr} -> + | Lfunction{kind; params; body = l; attr; loc} -> begin match simplif l with - Lfunction{kind=Curried; params=params'; body; attr} + Lfunction{kind=Curried; params=params'; body; attr; loc} when kind = Curried && optimize -> - Lfunction{kind; params = params @ params'; body; attr} + Lfunction{kind; params = params @ params'; body; attr; loc} | body -> - Lfunction{kind; params; body; attr} + Lfunction{kind; params; body; attr; loc} end - | Llet(str, v, Lvar w, l2) when optimize -> + | Llet(_str, _k, v, Lvar w, l2) when optimize -> Hashtbl.add subst v (simplif (Lvar w)); simplif l2 - | Llet(Strict, v, Lprim(Pmakeblock(0, Mutable), [linit]), lbody) + | Llet(Strict, kind, v, + Lprim(Pmakeblock(0, Mutable, kind_ref) as prim, [linit], loc), lbody) when optimize -> let slinit = simplif linit in let slbody = simplif lbody in begin try - mklet (Variable, v, slinit, eliminate_ref v slbody) + let kind = match kind_ref with + | None -> Pgenval + | Some [field_kind] -> field_kind + | Some _ -> assert false + in + mklet Variable kind v slinit (eliminate_ref v slbody) with Real_reference -> - mklet(Strict, v, Lprim(Pmakeblock(0, Mutable), [slinit]), slbody) + mklet Strict kind v (Lprim(prim, [slinit], loc)) slbody end - | Llet(Alias, v, l1, l2) -> + | Llet(Alias, kind, v, l1, l2) -> begin match count_var v with 0 -> simplif l2 | 1 when optimize -> Hashtbl.add subst v (simplif l1); simplif l2 - | n -> Llet(Alias, v, simplif l1, simplif l2) + | _ -> Llet(Alias, kind, v, simplif l1, simplif l2) end - | Llet(StrictOpt, v, l1, l2) -> + | Llet(StrictOpt, kind, v, l1, l2) -> begin match count_var v with 0 -> simplif l2 - | n -> mklet(Alias, v, simplif l1, simplif l2) + | _ -> mklet Alias kind v (simplif l1) (simplif l2) end - | Llet(kind, v, l1, l2) -> mklet(kind, v, simplif l1, simplif l2) + | Llet(str, kind, v, l1, l2) -> mklet str kind v (simplif l1) (simplif l2) | Lletrec(bindings, body) -> Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body) - | Lprim(p, ll) -> Lprim(p, List.map simplif ll) + | Lprim(p, ll, loc) -> Lprim(p, List.map simplif ll, loc) | Lswitch(l, sw) -> let new_l = simplif l and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts @@ -501,10 +507,10 @@ let simplify_lets lam = (new_l, {sw with sw_consts = new_consts ; sw_blocks = new_blocks; sw_failaction = new_fail}) - | Lstringswitch (l,sw,d) -> + | Lstringswitch (l,sw,d,loc) -> Lstringswitch (simplif l,List.map (fun (s,l) -> s,simplif l) sw, - Misc.may_map simplif d) + Misc.may_map simplif d,loc) | Lstaticraise (i,ls) -> Lstaticraise (i, List.map simplif ls) | Lstaticcatch(l1, (i,args), l2) -> @@ -531,7 +537,7 @@ let simplify_lets lam = (* Tail call info in annotation files *) let is_tail_native_heuristic : (int -> bool) ref = - ref (fun n -> true) + ref (fun _ -> true) let rec emit_tail_infos is_tail lambda = let call_kind args = @@ -554,26 +560,26 @@ let rec emit_tail_infos is_tail lambda = Stypes.record (Stypes.An_call (ap.ap_loc, call_kind ap.ap_args)) | Lfunction {body = lam} -> emit_tail_infos true lam - | Llet (_, _, lam, body) -> + | Llet (_str, _k, _, lam, body) -> emit_tail_infos false lam; emit_tail_infos is_tail body | Lletrec (bindings, body) -> List.iter (fun (_, lam) -> emit_tail_infos false lam) bindings; emit_tail_infos is_tail body - | Lprim (Pidentity, [arg]) -> + | Lprim ((Pidentity | Pbytes_to_string | Pbytes_of_string), [arg], _) -> emit_tail_infos is_tail arg - | Lprim (Psequand, [arg1; arg2]) - | Lprim (Psequor, [arg1; arg2]) -> + | Lprim (Psequand, [arg1; arg2], _) + | Lprim (Psequor, [arg1; arg2], _) -> emit_tail_infos false arg1; emit_tail_infos is_tail arg2 - | Lprim (_, l) -> + | Lprim (_, l, _) -> list_emit_tail_infos false l | Lswitch (lam, sw) -> emit_tail_infos false lam; list_emit_tail_infos_fun snd is_tail sw.sw_consts; list_emit_tail_infos_fun snd is_tail sw.sw_blocks; Misc.may (emit_tail_infos is_tail) sw.sw_failaction - | Lstringswitch (lam, sw, d) -> + | Lstringswitch (lam, sw, d, _) -> emit_tail_infos false lam; List.iter (fun (_,lam) -> emit_tail_infos is_tail lam) @@ -627,14 +633,14 @@ and list_emit_tail_infos is_tail = function's body. *) let split_default_wrapper ?(create_wrapper_body = fun lam -> lam) - fun_id kind params body attr = + ~id:fun_id ~kind ~params ~body ~attr ~wrapper_attr ~loc () = let rec aux map = function - | Llet(Strict, id, (Lifthenelse(Lvar optparam, _, _) as def), rest) when + | Llet(Strict, k, id, (Lifthenelse(Lvar optparam, _, _) as def), rest) when Ident.name optparam = "*opt*" && List.mem optparam params && not (List.mem_assoc optparam map) -> let wrapper_body, inner = aux ((optparam, id) :: map) rest in - Llet(Strict, id, def, wrapper_body), inner + Llet(Strict, k, id, def, wrapper_body), inner | _ when map = [] -> raise Exit | body -> (* Check that those *opt* identifiers don't appear in the remaining @@ -664,22 +670,27 @@ let split_default_wrapper ?(create_wrapper_body = fun lam -> lam) in let body = Lambda.subst_lambda subst body in let inner_fun = - Lfunction { kind = Curried; params = new_ids; body; attr; } + Lfunction { kind = Curried; params = new_ids; body; attr; loc; } in (wrapper_body, (inner_id, inner_fun)) in try let wrapper_body, inner = aux [] body in [(fun_id, Lfunction{kind; params; body = create_wrapper_body wrapper_body; - attr}); inner] + attr = wrapper_attr; loc}); inner] with Exit -> - [(fun_id, Lfunction{kind; params; body; attr})] + [(fun_id, Lfunction{kind; params; body; attr; loc})] + +module Hooks = Misc.MakeHooks(struct + type t = lambda + end) (* The entry point: simplification + emission of tailcall annotations, if needed. *) -let simplify_lambda lam = +let simplify_lambda sourcefile lam = let res = simplify_lets (simplify_exits lam) in + let res = Hooks.apply_hooks { Misc.sourcefile } res in if !Clflags.annotations || Warnings.is_active Warnings.Expect_tailcall then emit_tail_infos true res; res diff --git a/bytecomp/simplif.mli b/bytecomp/simplif.mli index 65b8fb03..6736ffc3 100644 --- a/bytecomp/simplif.mli +++ b/bytecomp/simplif.mli @@ -20,17 +20,22 @@ open Lambda -val simplify_lambda: lambda -> lambda +val simplify_lambda: string -> lambda -> lambda val split_default_wrapper : ?create_wrapper_body:(lambda -> lambda) - -> Ident.t - -> function_kind - -> Ident.t list - -> lambda - -> function_attribute + -> id:Ident.t + -> kind:function_kind + -> params:Ident.t list + -> body:lambda + -> attr:function_attribute + -> wrapper_attr:function_attribute + -> loc:Location.t + -> unit -> (Ident.t * lambda) list (* To be filled by asmcomp/selectgen.ml *) val is_tail_native_heuristic: (int -> bool) ref (* # arguments -> can tailcall *) + +module Hooks : Misc.HookSig with type t = lambda diff --git a/bytecomp/switch.ml b/bytecomp/switch.ml index dfcf77e3..fbde4452 100644 --- a/bytecomp/switch.ml +++ b/bytecomp/switch.ml @@ -390,13 +390,13 @@ let rec opt_count top cases = if lcases < !cut then enum top cases else if lcases < !more_cut then - heuristic top cases + heuristic cases else - divide top cases in + divide cases in Hashtbl.add t key r ; r -and divide top cases = +and divide cases = let lcases = Array.length cases in let m = lcases/2 in let _,left,right = coupe cases m in @@ -412,10 +412,10 @@ and divide top cases = add_test cm cml ; Sep m,(cm, ci) -and heuristic top cases = +and heuristic cases = let lcases = Array.length cases in - let sep,csep = divide false cases + let sep,csep = divide cases and inter,cinter = if !ok_inter then begin @@ -589,7 +589,7 @@ and enum top cases = else begin - let w,c = opt_count false cases in + let w,_c = opt_count false cases in (* Printf.fprintf stderr "off=%d tactic=%a for %a\n" @@ -664,13 +664,13 @@ let switch_min = ref 3 (* Particular case 0, 1, 2 *) let particular_case cases i j = j-i = 2 && - (let l1,h1,act1 = cases.(i) - and l2,h2,act2 = cases.(i+1) + (let l1,_h1,act1 = cases.(i) + and l2,_h2,_act2 = cases.(i+1) and l3,h3,act3 = cases.(i+2) in l1+1=l2 && l2+1=l3 && l3=h3 && act1 <> act3) -let approx_count cases i j n_actions = +let approx_count cases i j = let l = j-i+1 in if l < !cut then let _,(_,{n=ntests}) = opt_count false (Array.sub cases i l) in @@ -680,12 +680,12 @@ let approx_count cases i j n_actions = (* Sends back a boolean that says whether is switch is worth or not *) -let dense {cases=cases ; actions=actions} i j = +let dense {cases} i j = if i=j then true else let l,_,_ = cases.(i) and _,h,_ = cases.(j) in - let ntests = approx_count cases i j (Array.length actions) in + let ntests = approx_count cases i j in (* (ntests+1) >= theta * (h-l+1) *) @@ -701,8 +701,8 @@ let dense {cases=cases ; actions=actions} i j = Software Practice and Exprience Vol. 24(2) 233 (Feb 1994) *) -let comp_clusters ({cases=cases ; actions=actions} as s) = - let len = Array.length cases in +let comp_clusters s = + let len = Array.length s.cases in let min_clusters = Array.make len max_int and k = Array.make len 0 in let get_min i = if i < 0 then 0 else min_clusters.(i) in diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index 22810cfc..8e96f498 100644 --- a/bytecomp/symtable.ml +++ b/bytecomp/symtable.ml @@ -332,12 +332,12 @@ let check_global_initialized patchlist = List.fold_left (fun accu rel -> match rel with - (Reloc_setglobal id, pos) -> id :: accu + (Reloc_setglobal id, _pos) -> id :: accu | _ -> accu) [] patchlist in (* Then check that all referenced, not defined globals have a value *) let check_reference = function - (Reloc_getglobal id, pos) -> + (Reloc_getglobal id, _pos) -> if not (List.mem id defined_globals) && Obj.is_int (get_global_value id) then raise (Error(Uninitialized_global(Ident.name id))) diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index a2478099..fe5a203f 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -29,12 +29,14 @@ exception Error of Location.t * error let lfunction params body = if params = [] then body else match body with - | Lfunction {kind = Curried; params = params'; body = body'; attr} -> - Lfunction {kind = Curried; params = params @ params'; body = body'; attr} + | Lfunction {kind = Curried; params = params'; body = body'; attr; loc} -> + Lfunction {kind = Curried; params = params @ params'; body = body'; attr; + loc} | _ -> Lfunction {kind = Curried; params; body; - attr = default_function_attribute} + attr = default_function_attribute; + loc = Location.none} let lapply ap = match ap.ap_func with @@ -54,7 +56,7 @@ let mkappl (func, args) = let lsequence l1 l2 = if l2 = lambda_unit then l1 else Lsequence(l1, l2) -let lfield v i = Lprim(Pfield i, [Lvar v]) +let lfield v i = Lprim(Pfield i, [Lvar v], Location.none) let transl_label l = share (Const_immstring l) @@ -69,7 +71,7 @@ let set_inst_var obj id expr = | Pointer -> Paddrarray | Immediate -> Pintarray in - Lprim(Parraysetu kind, [Lvar obj; Lvar id; transl_exp expr]) + Lprim(Parraysetu kind, [Lvar obj; Lvar id; transl_exp expr], Location.none) let transl_val tbl create name = mkappl (oo_prim (if create then "new_variable" else "get_variable"), @@ -78,7 +80,7 @@ let transl_val tbl create name = let transl_vals tbl create strict vals rem = List.fold_right (fun (name, id) rem -> - Llet(strict, id, transl_val tbl create name, rem)) + Llet(strict, Pgenval, id, transl_val tbl create name, rem)) vals rem let meths_super tbl meths inh_meths = @@ -93,7 +95,8 @@ let meths_super tbl meths inh_meths = let bind_super tbl (vals, meths) cl_init = transl_vals tbl false StrictOpt vals - (List.fold_right (fun (nm, id, def) rem -> Llet(StrictOpt, id, def, rem)) + (List.fold_right (fun (_nm, id, def) rem -> + Llet(StrictOpt, Pgenval, id, def, rem)) meths cl_init) let create_object cl obj init = @@ -106,7 +109,7 @@ let create_object cl obj init = [obj; Lvar cl])) else begin (inh_init, - Llet(Strict, obj', + Llet(Strict, Pgenval, obj', mkappl (oo_prim "create_object_opt", [obj; Lvar cl]), Lsequence(obj_init, if not has_init then Lvar obj' else @@ -117,7 +120,7 @@ let create_object cl obj init = let name_pattern default p = match p.pat_desc with | Tpat_var (id, _) -> id - | Tpat_alias(p, id, _) -> id + | Tpat_alias(_, id, _) -> id | _ -> Ident.create default let normalize_cl_path cl path = @@ -130,7 +133,10 @@ let rec build_object_init cl_table obj params inh_init obj_init cl = let envs, inh_init = inh_init in let env = match envs with None -> [] - | Some envs -> [Lprim(Pfield (List.length inh_init + 1), [Lvar envs])] + | Some envs -> + [Lprim(Pfield (List.length inh_init + 1), + [Lvar envs], + Location.none)] in ((envs, (obj_init, normalize_cl_path cl path) ::inh_init), @@ -174,6 +180,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl = let param = name_pattern "param" pat in Lfunction {kind = Curried; params = param::params; attr = default_function_attribute; + loc = pat.pat_loc; body = Matching.for_function pat.pat_loc None (Lvar param) [pat, rem] partial} in @@ -192,12 +199,12 @@ let rec build_object_init cl_table obj params inh_init obj_init cl = build_object_init cl_table obj (vals @ params) inh_init obj_init cl in (inh_init, Translcore.transl_let rec_flag defs obj_init) - | Tcl_constraint (cl, _, vals, pub_meths, concr_meths) -> + | Tcl_constraint (cl, _, _vals, _pub_meths, _concr_meths) -> build_object_init cl_table obj params inh_init obj_init cl let rec build_object_init_0 cl_table params cl copy_env subst_env top ids = match cl.cl_desc with - Tcl_let (rec_flag, defs, vals, cl) -> + Tcl_let (_rec_flag, _defs, vals, cl) -> let vals = List.map (fun (id, _, e) -> id,e) vals in build_object_init_0 cl_table (vals@params) cl copy_env subst_env top ids | _ -> @@ -206,14 +213,14 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env top ids = let obj = if ids = [] then lambda_unit else Lvar self in let envs = if top then None else Some env in let ((_,inh_init), obj_init) = - build_object_init cl_table obj params (envs,[]) (copy_env env) cl in + build_object_init cl_table obj params (envs,[]) copy_env cl in let obj_init = if ids = [] then obj_init else lfunction [self] obj_init in (inh_init, lfunction [env] (subst_env env inh_init obj_init)) let bind_method tbl lab id cl_init = - Llet(Strict, id, mkappl (oo_prim "get_method_label", + Llet(Strict, Pgenval, id, mkappl (oo_prim "get_method_label", [Lvar tbl; transl_label lab]), cl_init) @@ -228,11 +235,12 @@ let bind_methods tbl meths vals cl_init = if nvals = 0 then "get_method_labels", [] else "new_methods_variables", [transl_meth_list (List.map fst vals)] in - Llet(Strict, ids, + Llet(Strict, Pgenval, ids, mkappl (oo_prim getter, [Lvar tbl; transl_meth_list (List.map fst methl)] @ names), List.fold_right - (fun (lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam)) + (fun (_lab,id) lam -> decr i; Llet(StrictOpt, Pgenval, id, + lfield ids !i, lam)) (methl @ vals) cl_init) let output_methods tbl methods lam = @@ -242,7 +250,8 @@ let output_methods tbl methods lam = lsequence (mkappl(oo_prim "set_method", [Lvar tbl; lab; code])) lam | _ -> lsequence (mkappl(oo_prim "set_methods", - [Lvar tbl; Lprim(Pmakeblock(0,Immutable), methods)])) + [Lvar tbl; Lprim(Pmakeblock(0,Immutable,None), + methods, Location.none)])) lam let rec ignore_cstrs cl = @@ -262,12 +271,13 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = match cl.cl_desc with Tcl_ident ( path, _, _) -> begin match inh_init with - (obj_init, path')::inh_init -> + (obj_init, _path')::inh_init -> let lpath = transl_path ~loc:cl.cl_loc cl.cl_env path in (inh_init, - Llet (Strict, obj_init, - mkappl(Lprim(Pfield 1, [lpath]), Lvar cla :: - if top then [Lprim(Pfield 3, [lpath])] else []), + Llet (Strict, Pgenval, obj_init, + mkappl(Lprim(Pfield 1, [lpath], Location.none), Lvar cla :: + if top then [Lprim(Pfield 3, [lpath], Location.none)] + else []), bind_super cla super cl_init)) | _ -> assert false @@ -300,7 +310,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = if !Clflags.native_code && List.length met_code = 1 then (* Force correct naming of method for profiles *) let met = Ident.create ("method_" ^ name.txt) in - [Llet(Strict, met, List.hd met_code, Lvar met)] + [Llet(Strict, Pgenval, met, List.hd met_code, Lvar met)] else met_code in (inh_init, cl_init, @@ -319,15 +329,15 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = in let cl_init = output_methods cla methods cl_init in (inh_init, bind_methods cla str.cstr_meths values cl_init) - | Tcl_fun (_, pat, vals, cl, _) -> + | Tcl_fun (_, _pat, vals, cl, _) -> let (inh_init, cl_init) = build_class_init cla cstr super inh_init cl_init msubst top cl in let vals = List.map bind_id_as_val vals in (inh_init, transl_vals cla true StrictOpt vals cl_init) - | Tcl_apply (cl, exprs) -> + | Tcl_apply (cl, _exprs) -> build_class_init cla cstr super inh_init cl_init msubst top cl - | Tcl_let (rec_flag, defs, vals, cl) -> + | Tcl_let (_rec_flag, _defs, vals, cl) -> let (inh_init, cl_init) = build_class_init cla cstr super inh_init cl_init msubst top cl in @@ -353,19 +363,21 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = let cl_init = List.fold_left (fun init (nm, id, _) -> - Llet(StrictOpt, id, lfield inh (index nm concr_meths + ofs), + Llet(StrictOpt, Pgenval, id, + lfield inh (index nm concr_meths + ofs), init)) cl_init methids in let cl_init = List.fold_left (fun init (nm, id) -> - Llet(StrictOpt, id, lfield inh (index nm vals + 1), init)) + Llet(StrictOpt, Pgenval, id, + lfield inh (index nm vals + 1), init)) cl_init valids in (inh_init, - Llet (Strict, inh, + Llet (Strict, Pgenval, inh, mkappl(oo_prim "inherits", narrow_args @ [lpath; Lconst(Const_pointer(if top then 1 else 0))]), - Llet(StrictOpt, obj_init, lfield inh 0, cl_init))) + Llet(StrictOpt, Pgenval, obj_init, lfield inh 0, cl_init))) | _ -> let core cl_init = build_class_init cla true super inh_init cl_init msubst top cl @@ -381,7 +393,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = let rec build_class_lets cl ids = match cl.cl_desc with - Tcl_let (rec_flag, defs, vals, cl') -> + Tcl_let (rec_flag, defs, _vals, cl') -> let env, wrap = build_class_lets cl' [] in (env, fun x -> let lam = Translcore.transl_let rec_flag defs (wrap x) in @@ -420,6 +432,7 @@ let rec transl_class_rebind obj_init cl vf = let param = name_pattern "param" pat in Lfunction {kind = Curried; params = param::params; attr = default_function_attribute; + loc = pat.pat_loc; body = Matching.for_function pat.pat_loc None (Lvar param) [pat, rem] partial} in @@ -430,7 +443,7 @@ let rec transl_class_rebind obj_init cl vf = | Tcl_apply (cl, oexprs) -> let path, obj_init = transl_class_rebind obj_init cl vf in (path, transl_apply obj_init oexprs Location.none) - | Tcl_let (rec_flag, defs, vals, cl) -> + | Tcl_let (rec_flag, defs, _vals, cl) -> let path, obj_init = transl_class_rebind obj_init cl vf in (path, Translcore.transl_let rec_flag defs obj_init) | Tcl_structure _ -> raise Exit @@ -446,7 +459,7 @@ let rec transl_class_rebind obj_init cl vf = let rec transl_class_rebind_0 self obj_init cl vf = match cl.cl_desc with - Tcl_let (rec_flag, defs, vals, cl) -> + Tcl_let (rec_flag, defs, _vals, cl) -> let path, obj_init = transl_class_rebind_0 self obj_init cl vf in (path, Translcore.transl_let rec_flag defs obj_init) | _ -> @@ -477,19 +490,20 @@ let transl_class_rebind ids cl vf = and table = Ident.create "table" and envs = Ident.create "envs" in Llet( - Strict, new_init, lfunction [obj_init] obj_init', + Strict, Pgenval, new_init, lfunction [obj_init] obj_init', Llet( - Alias, cla, transl_normal_path path, - Lprim(Pmakeblock(0, Immutable), + Alias, Pgenval, cla, transl_normal_path path, + Lprim(Pmakeblock(0, Immutable, None), [mkappl(Lvar new_init, [lfield cla 0]); lfunction [table] - (Llet(Strict, env_init, + (Llet(Strict, Pgenval, env_init, mkappl(lfield cla 1, [Lvar table]), lfunction [envs] (mkappl(Lvar new_init, [mkappl(Lvar env_init, [Lvar envs])])))); lfield cla 2; - lfield cla 3]))) + lfield cla 3], + Location.none))) with Exit -> lambda_unit @@ -498,9 +512,9 @@ let transl_class_rebind ids cl vf = let rec module_path = function Lvar id -> let s = Ident.name id in s <> "" && s.[0] >= 'A' && s.[0] <= 'Z' - | Lprim(Pfield _, [p]) -> module_path p - | Lprim(Pgetglobal _, []) -> true - | _ -> false + | Lprim(Pfield _, [p], _) -> module_path p + | Lprim(Pgetglobal _, [], _) -> true + | _ -> false let const_path local = function Lvar id -> not (List.mem id local) @@ -515,16 +529,16 @@ let rec builtin_meths self env env2 body = let conv = function (* Lvar s when List.mem s self -> "_self", [] *) | p when const_path p -> "const", [p] - | Lprim(Parrayrefu _, [Lvar s; Lvar n]) when List.mem s self -> + | Lprim(Parrayrefu _, [Lvar s; Lvar n], _) when List.mem s self -> "var", [Lvar n] - | Lprim(Pfield n, [Lvar e]) when Ident.same e env -> + | Lprim(Pfield n, [Lvar e], _) when Ident.same e env -> "env", [Lvar env2; Lconst(Const_pointer n)] | Lsend(Self, met, Lvar s, [], _) when List.mem s self -> "meth", [met] | _ -> raise Not_found in match body with - | Llet(_, s', Lvar s, body) when List.mem s self -> + | Llet(_str, _k, s', Lvar s, body) when List.mem s self -> builtin_meths (s'::self) env env2 body | Lapply{ap_func = f; ap_args = [arg]} when const_path f -> let s, args = conv arg in ("app_"^s, f :: args) @@ -547,10 +561,10 @@ let rec builtin_meths self env env2 body = ("send_"^s, met :: args) | Lfunction {kind = Curried; params = [x]; body} -> let rec enter self = function - | Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x']) + | Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x'], _) when Ident.same x x' && List.mem s self -> ("set_var", [Lvar n]) - | Llet(_, s', Lvar s, body) when List.mem s self -> + | Llet(_str, _k, s', Lvar s, body) when List.mem s self -> enter (s'::self) body | _ -> raise Not_found in enter self body @@ -669,24 +683,27 @@ let transl_class ids cl_id pub_meths cl vflag = with Not_found -> [lfunction (self :: args) (if not (IdentSet.mem env (free_variables body')) then body' else - Llet(Alias, env, + Llet(Alias, Pgenval, env, Lprim(Parrayrefu Paddrarray, - [Lvar self; Lvar env2]), body'))] + [Lvar self; Lvar env2], + Location.none), + body'))] end | _ -> assert false in let new_ids_init = ref [] in let env1 = Ident.create "env" and env1' = Ident.create "env'" in - let copy_env envs self = + let copy_env self = if top then lambda_unit else Lifused(env2, Lprim(Parraysetu Paddrarray, - [Lvar self; Lvar env2; Lvar env1'])) + [Lvar self; Lvar env2; Lvar env1'], + Location.none)) and subst_env envs l lam = if top then lam else (* must be called only once! *) let lam = subst_lambda (subst env1 lam 1 new_ids_init) lam in - Llet(Alias, env1, (if l = [] then Lvar envs else lfield envs 0), - Llet(Alias, env1', + Llet(Alias, Pgenval, env1, (if l = [] then Lvar envs else lfield envs 0), + Llet(Alias, Pgenval, env1', (if !new_ids_init = [] then Lvar env1 else lfield env1 0), lam)) in @@ -716,10 +733,10 @@ let transl_class ids cl_id pub_meths cl vflag = if name' <> name then raise(Error(cl.cl_loc, Tags(name, name')))) tags pub_meths; let ltable table lam = - Llet(Strict, table, + Llet(Strict, Pgenval, table, mkappl (oo_prim "create_table", [transl_meth_list pub_meths]), lam) and ldirect obj_init = - Llet(Strict, obj_init, cl_init, + Llet(Strict, Pgenval, obj_init, cl_init, Lsequence(mkappl (oo_prim "init_class", [Lvar cla]), mkappl (Lvar obj_init, [lambda_unit]))) in @@ -730,8 +747,9 @@ let transl_class ids cl_id pub_meths cl vflag = and lclass lam = let cl_init = llets (Lfunction{kind = Curried; attr = default_function_attribute; + loc = Location.none; params = [cla]; body = cl_init}) in - Llet(Strict, class_init, cl_init, lam (free_variables cl_init)) + Llet(Strict, Pgenval, class_init, cl_init, lam (free_variables cl_init)) and lbody fv = if List.for_all (fun id -> not (IdentSet.mem id fv)) ids then mkappl (oo_prim "make_class",[transl_meth_list pub_meths; @@ -739,18 +757,21 @@ let transl_class ids cl_id pub_meths cl vflag = else ltable table ( Llet( - Strict, env_init, mkappl (Lvar class_init, [Lvar table]), + Strict, Pgenval, env_init, mkappl (Lvar class_init, [Lvar table]), Lsequence( mkappl (oo_prim "init_class", [Lvar table]), - Lprim(Pmakeblock(0, Immutable), + Lprim(Pmakeblock(0, Immutable, None), [mkappl (Lvar env_init, [lambda_unit]); - Lvar class_init; Lvar env_init; lambda_unit])))) + Lvar class_init; Lvar env_init; lambda_unit], + Location.none)))) and lbody_virt lenvs = - Lprim(Pmakeblock(0, Immutable), + Lprim(Pmakeblock(0, Immutable, None), [lambda_unit; Lfunction{kind = Curried; attr = default_function_attribute; + loc = Location.none; params = [cla]; body = cl_init}; - lambda_unit; lenvs]) + lambda_unit; lenvs], + Location.none) in (* Still easy: a class defined at toplevel *) if top && concrete then lclass lbody else @@ -766,51 +787,63 @@ let transl_class ids cl_id pub_meths cl vflag = let lenv = let menv = if !new_ids_meths = [] then lambda_unit else - Lprim(Pmakeblock(0, Immutable), - List.map (fun id -> Lvar id) !new_ids_meths) in + Lprim(Pmakeblock(0, Immutable, None), + List.map (fun id -> Lvar id) !new_ids_meths, + Location.none) in if !new_ids_init = [] then menv else - Lprim(Pmakeblock(0, Immutable), - menv :: List.map (fun id -> Lvar id) !new_ids_init) + Lprim(Pmakeblock(0, Immutable, None), + menv :: List.map (fun id -> Lvar id) !new_ids_init, + Location.none) and linh_envs = - List.map (fun (_, p) -> Lprim(Pfield 3, [transl_normal_path p])) + List.map + (fun (_, p) -> Lprim(Pfield 3, [transl_normal_path p], Location.none)) (List.rev inh_init) in let make_envs lam = - Llet(StrictOpt, envs, + Llet(StrictOpt, Pgenval, envs, (if linh_envs = [] then lenv else - Lprim(Pmakeblock(0, Immutable), lenv :: linh_envs)), + Lprim(Pmakeblock(0, Immutable, None), + lenv :: linh_envs, Location.none)), lam) and def_ids cla lam = - Llet(StrictOpt, env2, + Llet(StrictOpt, Pgenval, env2, mkappl (oo_prim "new_variable", [Lvar cla; transl_label ""]), lam) in let inh_paths = List.filter - (fun (_,path) -> List.mem (Path.head path) new_ids) inh_init in + (fun (_,path) -> List.mem (Path.head path) new_ids) inh_init + in let inh_keys = - List.map (fun (_,p) -> Lprim(Pfield 1, [transl_normal_path p])) inh_paths in + List.map (fun (_,p) -> Lprim(Pfield 1, [transl_normal_path p], + Location.none)) + inh_paths + in let lclass lam = - Llet(Strict, class_init, + Llet(Strict, Pgenval, class_init, Lfunction{kind = Curried; params = [cla]; attr = default_function_attribute; + loc = Location.none; body = def_ids cla cl_init}, lam) and lcache lam = - if inh_keys = [] then Llet(Alias, cached, Lvar tables, lam) else - Llet(Strict, cached, + if inh_keys = [] then Llet(Alias, Pgenval, cached, Lvar tables, lam) else + Llet(Strict, Pgenval, cached, mkappl (oo_prim "lookup_tables", - [Lvar tables; Lprim(Pmakeblock(0, Immutable), inh_keys)]), + [Lvar tables; Lprim(Pmakeblock(0, Immutable, None), + inh_keys, Location.none)]), lam) and lset cached i lam = - Lprim(Psetfield(i, Pointer, Assignment), [Lvar cached; lam]) + Lprim(Psetfield(i, Pointer, Assignment), + [Lvar cached; lam], Location.none) in let ldirect () = ltable cla - (Llet(Strict, env_init, def_ids cla cl_init, + (Llet(Strict, Pgenval, env_init, def_ids cla cl_init, Lsequence(mkappl (oo_prim "init_class", [Lvar cla]), lset cached 0 (Lvar env_init)))) and lclass_virt () = lset cached 0 (Lfunction{kind = Curried; attr = default_function_attribute; + loc = Location.none; params = [cla]; body = def_ids cla cl_init}) in llets ( @@ -825,13 +858,14 @@ let transl_class ids cl_id pub_meths cl vflag = Lvar class_init; Lvar cached]))), make_envs ( if ids = [] then mkappl (lfield cached 0, [lenvs]) else - Lprim(Pmakeblock(0, Immutable), - if concrete then + Lprim(Pmakeblock(0, Immutable, None), + (if concrete then [mkappl (lfield cached 0, [lenvs]); lfield cached 1; lfield cached 0; lenvs] - else [lambda_unit; lfield cached 0; lambda_unit; lenvs] + else [lambda_unit; lfield cached 0; lambda_unit; lenvs]), + Location.none ))))) (* Wrapper for class compilation *) diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 42d02702..8b30d9fe 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -37,13 +37,35 @@ 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) : + ref((fun _cc _rootpath _modl -> assert false) : module_coercion -> Path.t option -> module_expr -> lambda) let transl_object = - ref (fun id s cl -> assert false : + ref (fun _id _s _cl -> assert false : Ident.t -> string list -> class_expr -> lambda) +(* Compile an exception/extension definition *) + +let prim_fresh_oo_id = + Pccall (Primitive.simple ~name:"caml_fresh_oo_id" ~arity:1 ~alloc:false) + +let transl_extension_constructor env path ext = + let name = + match path, !Clflags.for_package with + None, _ -> Ident.name ext.ext_id + | Some p, None -> Path.name p + | Some p, Some pack -> Printf.sprintf "%s.%s" pack (Path.name p) + in + let loc = ext.ext_loc in + match ext.ext_kind with + Text_decl _ -> + Lprim (Pmakeblock (Obj.object_tag, Immutable, None), + [Lconst (Const_base (Const_string (name, None))); + Lprim (prim_fresh_oo_id, [Lconst (Const_base (Const_int 0))], loc)], + loc) + | Text_rebind(path, _lid) -> + transl_path ~loc env path + (* Translation of primitives *) let comparisons_table = create_hashtable 11 [ @@ -53,6 +75,8 @@ let comparisons_table = create_hashtable 11 [ Pfloatcomp Ceq, Pccall(Primitive.simple ~name:"caml_string_equal" ~arity:2 ~alloc:false), + Pccall(Primitive.simple ~name:"caml_bytes_equal" ~arity:2 + ~alloc:false), Pbintcomp(Pnativeint, Ceq), Pbintcomp(Pint32, Ceq), Pbintcomp(Pint64, Ceq), @@ -63,6 +87,8 @@ let comparisons_table = create_hashtable 11 [ Pfloatcomp Cneq, Pccall(Primitive.simple ~name:"caml_string_notequal" ~arity:2 ~alloc:false), + Pccall(Primitive.simple ~name:"caml_bytes_notequal" ~arity:2 + ~alloc:false), Pbintcomp(Pnativeint, Cneq), Pbintcomp(Pint32, Cneq), Pbintcomp(Pint64, Cneq), @@ -73,6 +99,8 @@ let comparisons_table = create_hashtable 11 [ Pfloatcomp Clt, Pccall(Primitive.simple ~name:"caml_string_lessthan" ~arity:2 ~alloc:false), + Pccall(Primitive.simple ~name:"caml_bytes_lessthan" ~arity:2 + ~alloc:false), Pbintcomp(Pnativeint, Clt), Pbintcomp(Pint32, Clt), Pbintcomp(Pint64, Clt), @@ -83,6 +111,8 @@ let comparisons_table = create_hashtable 11 [ Pfloatcomp Cgt, Pccall(Primitive.simple ~name:"caml_string_greaterthan" ~arity:2 ~alloc: false), + Pccall(Primitive.simple ~name:"caml_bytes_greaterthan" ~arity:2 + ~alloc: false), Pbintcomp(Pnativeint, Cgt), Pbintcomp(Pint32, Cgt), Pbintcomp(Pint64, Cgt), @@ -93,6 +123,8 @@ let comparisons_table = create_hashtable 11 [ Pfloatcomp Cle, Pccall(Primitive.simple ~name:"caml_string_lessequal" ~arity:2 ~alloc:false), + Pccall(Primitive.simple ~name:"caml_bytes_lessequal" ~arity:2 + ~alloc:false), Pbintcomp(Pnativeint, Cle), Pbintcomp(Pint32, Cle), Pbintcomp(Pint64, Cle), @@ -103,6 +135,8 @@ let comparisons_table = create_hashtable 11 [ Pfloatcomp Cge, Pccall(Primitive.simple ~name:"caml_string_greaterequal" ~arity:2 ~alloc:false), + Pccall(Primitive.simple ~name:"caml_bytes_greaterequal" ~arity:2 + ~alloc:false), Pbintcomp(Pnativeint, Cge), Pbintcomp(Pint32, Cge), Pbintcomp(Pint64, Cge), @@ -120,6 +154,8 @@ let comparisons_table = create_hashtable 11 [ unboxed_compare "caml_float_compare" Unboxed_float, Pccall(Primitive.simple ~name:"caml_string_compare" ~arity:2 ~alloc:false), + Pccall(Primitive.simple ~name:"caml_bytes_compare" ~arity:2 + ~alloc:false), unboxed_compare "caml_nativeint_compare" (Unboxed_integer Pnativeint), unboxed_compare "caml_int32_compare" (Unboxed_integer Pint32), unboxed_compare "caml_int64_compare" (Unboxed_integer Pint64), @@ -128,12 +164,21 @@ let comparisons_table = create_hashtable 11 [ let primitives_table = create_hashtable 57 [ "%identity", Pidentity; + "%bytes_to_string", Pbytes_to_string; + "%bytes_of_string", Pbytes_of_string; "%ignore", Pignore; + "%revapply", Prevapply; + "%apply", Pdirapply; + "%loc_LOC", Ploc Loc_LOC; + "%loc_FILE", Ploc Loc_FILE; + "%loc_LINE", Ploc Loc_LINE; + "%loc_POS", Ploc Loc_POS; + "%loc_MODULE", Ploc Loc_MODULE; "%field0", Pfield 0; "%field1", Pfield 1; "%setfield0", Psetfield(0, Pointer, Assignment); - "%makeblock", Pmakeblock(0, Immutable); - "%makemutable", Pmakeblock(0, Mutable); + "%makeblock", Pmakeblock(0, Immutable, None); + "%makemutable", Pmakeblock(0, Mutable, None); "%raise", Praise Raise_regular; "%reraise", Praise Raise_reraise; "%raise_notrace", Praise Raise_notrace; @@ -141,6 +186,7 @@ let primitives_table = create_hashtable 57 [ "%sequor", Psequor; "%boolnot", Pnot; "%big_endian", Pctconst Big_endian; + "%backend_type", Pctconst Backend_type; "%word_size", Pctconst Word_size; "%int_size", Pctconst Int_size; "%max_wosize", Pctconst Max_wosize; @@ -153,8 +199,8 @@ let primitives_table = create_hashtable 57 [ "%addint", Paddint; "%subint", Psubint; "%mulint", Pmulint; - "%divint", Pdivint; - "%modint", Pmodint; + "%divint", Pdivint Safe; + "%modint", Pmodint Safe; "%andint", Pandint; "%orint", Porint; "%xorint", Pxorint; @@ -185,9 +231,14 @@ let primitives_table = create_hashtable 57 [ "%gefloat", Pfloatcomp Cge; "%string_length", Pstringlength; "%string_safe_get", Pstringrefs; - "%string_safe_set", Pstringsets; + "%string_safe_set", Pbytessets; "%string_unsafe_get", Pstringrefu; - "%string_unsafe_set", Pstringsetu; + "%string_unsafe_set", Pbytessetu; + "%bytes_length", Pbyteslength; + "%bytes_safe_get", Pbytesrefs; + "%bytes_safe_set", Pbytessets; + "%bytes_unsafe_get", Pbytesrefu; + "%bytes_unsafe_set", Pbytessetu; "%array_length", Parraylength Pgenarray; "%array_safe_get", Parrayrefs Pgenarray; "%array_safe_set", Parraysets Pgenarray; @@ -204,8 +255,8 @@ let primitives_table = create_hashtable 57 [ "%nativeint_add", Paddbint Pnativeint; "%nativeint_sub", Psubbint Pnativeint; "%nativeint_mul", Pmulbint Pnativeint; - "%nativeint_div", Pdivbint Pnativeint; - "%nativeint_mod", Pmodbint Pnativeint; + "%nativeint_div", Pdivbint { size = Pnativeint; is_safe = Safe }; + "%nativeint_mod", Pmodbint { size = Pnativeint; is_safe = Safe }; "%nativeint_and", Pandbint Pnativeint; "%nativeint_or", Porbint Pnativeint; "%nativeint_xor", Pxorbint Pnativeint; @@ -218,8 +269,8 @@ let primitives_table = create_hashtable 57 [ "%int32_add", Paddbint Pint32; "%int32_sub", Psubbint Pint32; "%int32_mul", Pmulbint Pint32; - "%int32_div", Pdivbint Pint32; - "%int32_mod", Pmodbint Pint32; + "%int32_div", Pdivbint { size = Pint32; is_safe = Safe }; + "%int32_mod", Pmodbint { size = Pint32; is_safe = Safe }; "%int32_and", Pandbint Pint32; "%int32_or", Porbint Pint32; "%int32_xor", Pxorbint Pint32; @@ -232,8 +283,8 @@ let primitives_table = create_hashtable 57 [ "%int64_add", Paddbint Pint64; "%int64_sub", Psubbint Pint64; "%int64_mul", Pmulbint Pint64; - "%int64_div", Pdivbint Pint64; - "%int64_mod", Pmodbint Pint64; + "%int64_div", Pdivbint { size = Pint64; is_safe = Safe }; + "%int64_mod", Pmodbint { size = Pint64; is_safe = Safe }; "%int64_and", Pandbint Pint64; "%int64_or", Porbint Pint64; "%int64_xor", Pxorbint Pint64; @@ -305,22 +356,11 @@ let primitives_table = create_hashtable 57 [ "%opaque", Popaque; ] -let prim_obj_dup = - Primitive.simple ~name:"caml_obj_dup" ~arity:1 ~alloc:true - -let find_primitive loc prim_name = - match prim_name with - "%revapply" -> Prevapply loc - | "%apply" -> Pdirapply loc - | "%loc_LOC" -> Ploc Loc_LOC - | "%loc_FILE" -> Ploc Loc_FILE - | "%loc_LINE" -> Ploc Loc_LINE - | "%loc_POS" -> Ploc Loc_POS - | "%loc_MODULE" -> Ploc Loc_MODULE - | name -> Hashtbl.find primitives_table name +let find_primitive prim_name = + Hashtbl.find primitives_table prim_name let specialize_comparison table env ty = - let (gencomp, intcomp, floatcomp, stringcomp, + let (gencomp, intcomp, floatcomp, stringcomp, bytescomp, nativeintcomp, int32comp, int64comp, _) = table in match () with | () when is_base_type env ty Predef.path_int @@ -328,6 +368,7 @@ let specialize_comparison table env ty = || (maybe_pointer_type env ty = Immediate) -> intcomp | () when is_base_type env ty Predef.path_float -> floatcomp | () when is_base_type env ty Predef.path_string -> stringcomp + | () when is_base_type env ty Predef.path_bytes -> bytescomp | () when is_base_type env ty Predef.path_nativeint -> nativeintcomp | () when is_base_type env ty Predef.path_int32 -> int32comp | () when is_base_type env ty Predef.path_int64 -> int64comp @@ -336,19 +377,19 @@ let specialize_comparison table env ty = (* Specialize a primitive from available type information, raise Not_found if primitive is unknown *) -let specialize_primitive loc p env ty ~has_constant_constructor = +let specialize_primitive p env ty ~has_constant_constructor = try let table = Hashtbl.find comparisons_table p.prim_name in - let (gencomp, intcomp, _, _, _, _, _, simplify_constant_constructor) = + let (gencomp, intcomp, _, _, _, _, _, _, simplify_constant_constructor) = table in if has_constant_constructor && simplify_constant_constructor then intcomp else match is_function_type env ty with - | Some (lhs,rhs) -> specialize_comparison table env lhs + | Some (lhs,_rhs) -> specialize_comparison table env lhs | None -> gencomp with Not_found -> - let p = find_primitive loc p.prim_name in + let p = find_primitive p.prim_name in (* Try strength reduction based on the type of the argument *) let params = match is_function_type env ty with | None -> [] @@ -357,7 +398,7 @@ let specialize_primitive loc p env ty ~has_constant_constructor = | Some (p2, _) -> [p1;p2] in match (p, params) with - (Psetfield(n, _, init), [p1; p2]) -> + (Psetfield(n, _, init), [_p1; p2]) -> Psetfield(n, maybe_pointer_type env p2, init) | (Parraylength Pgenarray, [p]) -> Parraylength(array_type_kind env p) | (Parrayrefu Pgenarray, p1 :: _) -> Parrayrefu(array_type_kind env p1) @@ -372,12 +413,15 @@ let specialize_primitive loc p env ty ~has_constant_constructor = p1 :: _) -> let (k, l) = bigarray_type_kind_and_layout env p1 in Pbigarrayset(unsafe, n, k, l) + | (Pmakeblock(tag, mut, None), fields) -> + let shape = List.map (Typeopt.value_kind env) fields in + Pmakeblock(tag, mut, Some shape) | _ -> p (* Eta-expand a primitive *) let used_primitives = Hashtbl.create 7 -let add_used_primitive loc p env path = +let add_used_primitive loc env path = match path with Some (Path.Pdot _ as path) -> let path = Env.normalize_path (Some loc) env path in @@ -388,9 +432,9 @@ let add_used_primitive loc p env path = let transl_primitive loc p env ty path = let prim = - try specialize_primitive loc p env ty ~has_constant_constructor:false + try specialize_primitive p env ty ~has_constant_constructor:false with Not_found -> - add_used_primitive loc p env path; + add_used_primitive loc env path; Pccall p in match prim with @@ -398,6 +442,7 @@ let transl_primitive loc p env ty path = let parm = Ident.create "prim" in Lfunction{kind = Curried; params = [parm]; body = Matching.inline_lazy_force (Lvar parm) Location.none; + loc = loc; attr = default_function_attribute } | Ploc kind -> let lam = lam_of_loc kind loc in @@ -407,7 +452,9 @@ let transl_primitive loc p env ty path = let param = Ident.create "prim" in Lfunction{kind = Curried; params = [param]; attr = default_function_attribute; - body = Lprim(Pmakeblock(0, Immutable), [lam; Lvar param])} + loc = loc; + body = Lprim(Pmakeblock(0, Immutable, None), + [lam; Lvar param], loc)} | _ -> assert false end | _ -> @@ -416,7 +463,8 @@ let transl_primitive loc p env ty path = let params = make_params p.prim_arity in Lfunction{ kind = Curried; params; attr = default_function_attribute; - body = Lprim(prim, List.map (fun id -> Lvar id) params) } + loc = loc; + body = Lprim(prim, List.map (fun id -> Lvar id) params, loc) } let transl_primitive_application loc prim env ty path args = let prim_name = prim.prim_name in @@ -428,11 +476,11 @@ let transl_primitive_application loc prim env ty path args = | [{exp_desc = Texp_variant(_, None)}; _] -> true | _ -> false in - specialize_primitive loc prim env ty ~has_constant_constructor + specialize_primitive prim env ty ~has_constant_constructor with Not_found -> if String.length prim_name > 0 && prim_name.[0] = '%' then raise(Error(loc, Unknown_builtin_primitive prim_name)); - add_used_primitive loc prim env path; + add_used_primitive loc env path; Pccall prim @@ -441,16 +489,16 @@ let transl_primitive_application loc prim env ty path args = let check_recursive_lambda idlist lam = let rec check_top idlist = function | Lvar v -> not (List.mem v idlist) - | Llet (_, _, _, _) as lam when check_recursive_recordwith idlist lam -> + | Llet _ as lam when check_recursive_recordwith idlist lam -> true - | Llet(str, id, arg, body) -> + | Llet(_str, _k, id, arg, body) -> check idlist arg && check_top (add_let id arg idlist) body | Lletrec(bindings, body) -> let idlist' = add_letrec bindings idlist in - List.for_all (fun (id, arg) -> check idlist' arg) bindings && + 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, _), _, _) -> 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 @@ -458,19 +506,19 @@ let check_recursive_lambda idlist lam = and check idlist = function | Lvar _ -> true - | Lfunction{kind; params; body} -> true - | Llet (_, _, _, _) as lam when check_recursive_recordwith idlist lam -> + | Lfunction _ -> true + | Llet _ as lam when check_recursive_recordwith idlist lam -> true - | Llet(str, id, arg, body) -> + | Llet(_str, _k, id, arg, body) -> check idlist arg && check (add_let id arg idlist) body | Lletrec(bindings, body) -> let idlist' = add_letrec bindings idlist in - List.for_all (fun (id, arg) -> check idlist' arg) bindings && + List.for_all (fun (_id, arg) -> check idlist' arg) bindings && check idlist' body - | Lprim(Pmakeblock(tag, mut), args) -> + | Lprim(Pmakeblock _, 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 @@ -491,13 +539,14 @@ let check_recursive_lambda idlist lam = (* reverse-engineering the code generated by transl_record case 2 *) (* If you change this, you probably need to change Bytegen.size_of_lambda. *) and check_recursive_recordwith idlist = function - | Llet (Strict, id1, Lprim (Pduprecord _, [e1]), body) -> + | Llet (Strict, _k, id1, Lprim (Pduprecord _, [e1], _), body) -> check_top idlist e1 && check_recordwith_updates idlist id1 body | _ -> false and check_recordwith_updates idlist id1 = function - | Lsequence (Lprim ((Psetfield _ | Psetfloatfield _), [Lvar id2; e1]), cont) + | Lsequence (Lprim ((Psetfield _ | Psetfloatfield _), [Lvar id2; e1], _), + cont) -> id2 = id1 && check idlist e1 && check_recordwith_updates idlist id1 cont | Lvar id2 -> id2 = id1 @@ -524,7 +573,7 @@ let rec name_pattern default = function | {c_lhs=p; _} :: rem -> match p.pat_desc with Tpat_var (id, _) -> id - | Tpat_alias(p, id, _) -> id + | Tpat_alias(_, id, _) -> id | _ -> name_pattern default rem (* Push the default values under the functional abstractions *) @@ -593,7 +642,7 @@ let rec push_defaults loc bindings cases partial = let event_before exp lam = match lam with | Lstaticraise (_,_) -> lam | _ -> - if !Clflags.debug + if !Clflags.debug && not !Clflags.native_code then Levent(lam, {lev_loc = exp.exp_loc; lev_kind = Lev_before; lev_repr = None; @@ -601,7 +650,7 @@ let event_before exp lam = match lam with else lam let event_after exp lam = - if !Clflags.debug + if !Clflags.debug && not !Clflags.native_code then Levent(lam, {lev_loc = exp.exp_loc; lev_kind = Lev_after exp.exp_type; lev_repr = None; @@ -609,7 +658,7 @@ let event_after exp lam = else lam let event_function exp lam = - if !Clflags.debug then + if !Clflags.debug && not !Clflags.native_code then let repr = Some (ref 0) in let (info, body) = lam repr in (info, @@ -623,9 +672,9 @@ let event_function exp lam = let primitive_is_ccall = function (* Determine if a primitive is a Pccall or will be turned later into a C function call that may raise an exception *) - | Pccall _ | Pstringrefs | Pstringsets | Parrayrefs _ | Parraysets _ | - Pbigarrayref _ | Pbigarrayset _ | Pduprecord _ | Pdirapply _ | - Prevapply _ -> true + | Pccall _ | Pstringrefs | Pbytesrefs | Pbytessets | Parrayrefs _ | + Parraysets _ | Pbigarrayref _ | Pbigarrayset _ | Pduprecord _ | Pdirapply | + Prevapply -> true | _ -> false (* Assertions *) @@ -634,12 +683,12 @@ let assert_failed exp = let (fname, line, char) = Location.get_pos_info exp.exp_loc.Location.loc_start in Lprim(Praise Raise_regular, [event_after exp - (Lprim(Pmakeblock(0, Immutable), + (Lprim(Pmakeblock(0, Immutable, None), [transl_normal_path Predef.path_assert_failure; Lconst(Const_block(0, [Const_base(Const_string (fname, None)); Const_base(Const_int line); - Const_base(Const_int char)]))]))]) + Const_base(Const_int char)]))], exp.exp_loc))], exp.exp_loc) ;; let rec cut n l = @@ -671,17 +720,19 @@ and transl_exp0 e = let obj = Ident.create "obj" and meth = Ident.create "meth" in Lfunction{kind = Curried; params = [obj; meth]; attr = default_function_attribute; + loc = e.exp_loc; body = Lsend(kind, Lvar meth, Lvar obj, [], e.exp_loc)} else if p.prim_name = "%sendcache" then let obj = Ident.create "obj" and meth = Ident.create "meth" in let cache = Ident.create "cache" and pos = Ident.create "pos" in Lfunction{kind = Curried; params = [obj; meth; cache; pos]; attr = default_function_attribute; + loc = e.exp_loc; body = Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos], e.exp_loc)} else transl_primitive e.exp_loc p e.exp_env e.exp_type (Some path) - | Texp_ident(path, _, {val_kind = Val_anc _}) -> + | Texp_ident(_, _, {val_kind = Val_anc _}) -> raise(Error(e.exp_loc, Free_super_var)) | Texp_ident(path, _, {val_kind = Val_reg | Val_self _}) -> transl_path ~loc:e.exp_loc e.exp_env path @@ -703,7 +754,8 @@ and transl_exp0 e = specialise = Translattribute.get_specialise_attribute e.exp_attributes; } in - Lfunction{kind; params; body; attr} + let loc = e.exp_loc in + Lfunction{kind; params; body; attr; loc} | Texp_apply({ exp_desc = Texp_ident(path, _, {val_kind = Val_prim p}); exp_type = prim_type } as funct, oargs) when List.length oargs >= p.prim_arity @@ -756,19 +808,19 @@ and transl_exp0 e = | _ -> k in - wrap0 (Lprim(Praise k, [event_after arg1 targ])) + wrap0 (Lprim(Praise k, [event_after arg1 targ], e.exp_loc)) | (Ploc kind, []) -> lam_of_loc kind e.exp_loc | (Ploc kind, [arg1]) -> let lam = lam_of_loc kind arg1.exp_loc in - Lprim(Pmakeblock(0, Immutable), lam :: argl) + Lprim(Pmakeblock(0, Immutable, None), lam :: argl, e.exp_loc) | (Ploc _, _) -> assert false | (_, _) -> begin match (prim, argl) with | (Plazyforce, [a]) -> wrap (Matching.inline_lazy_force a e.exp_loc) | (Plazyforce, _) -> assert false - |_ -> let p = Lprim(prim, argl) in + |_ -> let p = Lprim(prim, argl, e.exp_loc) in if primitive_is_ccall prim then wrap p else wrap0 p end end @@ -793,32 +845,34 @@ and transl_exp0 e = Ltrywith(transl_exp body, id, Matching.for_trywith (Lvar id) (transl_cases_try pat_expr_list)) | Texp_tuple el -> - let ll = transl_list el in + let ll, shape = transl_list_with_shape el in begin try Lconst(Const_block(0, List.map extract_constant ll)) with Not_constant -> - Lprim(Pmakeblock(0, Immutable), ll) + Lprim(Pmakeblock(0, Immutable, Some shape), ll, e.exp_loc) end | Texp_construct(_, cstr, args) -> - let ll = transl_list args in + let ll, shape = transl_list_with_shape args in if cstr.cstr_inlined <> None then begin match ll with | [x] -> x | _ -> assert false end else begin match cstr.cstr_tag with Cstr_constant n -> Lconst(Const_pointer n) + | Cstr_unboxed -> + (match ll with [v] -> v | _ -> assert false) | Cstr_block n -> begin try Lconst(Const_block(n, List.map extract_constant ll)) with Not_constant -> - Lprim(Pmakeblock(n, Immutable), ll) + Lprim(Pmakeblock(n, Immutable, Some shape), ll, e.exp_loc) end | Cstr_extension(path, is_const) -> if is_const then transl_path e.exp_env path else - Lprim(Pmakeblock(0, Immutable), - transl_path e.exp_env path :: ll) + Lprim(Pmakeblock(0, Immutable, Some (Pgenval :: shape)), + transl_path e.exp_env path :: ll, e.exp_loc) end | Texp_extension_constructor (_, path) -> transl_path e.exp_env path @@ -832,33 +886,34 @@ and transl_exp0 e = Lconst(Const_block(0, [Const_base(Const_int tag); extract_constant lam])) with Not_constant -> - Lprim(Pmakeblock(0, Immutable), - [Lconst(Const_base(Const_int tag)); lam]) + Lprim(Pmakeblock(0, Immutable, None), + [Lconst(Const_base(Const_int tag)); lam], e.exp_loc) end - | Texp_record ((_, lbl1, _) :: _ as lbl_expr_list, opt_init_expr) -> - transl_record e.exp_env lbl1.lbl_all lbl1.lbl_repres lbl_expr_list - opt_init_expr - | Texp_record ([], _) -> - fatal_error "Translcore.transl_exp: bad Texp_record" + | Texp_record {fields; representation; extended_expression} -> + transl_record e.exp_loc e.exp_env fields representation + extended_expression | Texp_field(arg, _, lbl) -> - let access = - match lbl.lbl_repres with - Record_regular | Record_inlined _ -> Pfield lbl.lbl_pos - | Record_float -> Pfloatfield lbl.lbl_pos - | Record_extension -> Pfield (lbl.lbl_pos + 1) - in - Lprim(access, [transl_exp arg]) + let targ = transl_exp arg in + begin match lbl.lbl_repres with + Record_regular | Record_inlined _ -> + Lprim (Pfield lbl.lbl_pos, [targ], e.exp_loc) + | Record_unboxed _ -> targ + | Record_float -> Lprim (Pfloatfield lbl.lbl_pos, [targ], e.exp_loc) + | Record_extension -> + Lprim (Pfield (lbl.lbl_pos + 1), [targ], e.exp_loc) + end | Texp_setfield(arg, _, lbl, newval) -> let access = match lbl.lbl_repres with Record_regular | Record_inlined _ -> Psetfield(lbl.lbl_pos, maybe_pointer newval, Assignment) + | Record_unboxed _ -> assert false | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment) | Record_extension -> Psetfield (lbl.lbl_pos + 1, maybe_pointer newval, Assignment) in - Lprim(access, [transl_exp arg; transl_exp newval]) + Lprim(access, [transl_exp arg; transl_exp newval], e.exp_loc) | Texp_array expr_list -> let kind = array_kind e in let ll = transl_list expr_list in @@ -885,8 +940,10 @@ and transl_exp0 e = 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]) + let imm_array = + Lprim (Pmakearray (kind, Immutable), ll, e.exp_loc) + in + Lprim (Pduparray (kind, Mutable), [imm_array], e.exp_loc) | cl -> let imm_array = match kind with @@ -897,10 +954,10 @@ and transl_exp0 e = | Pgenarray -> raise Not_constant (* can this really happen? *) in - Lprim (Pduparray (kind, Mutable), [imm_array]) + Lprim (Pduparray (kind, Mutable), [imm_array], e.exp_loc) end with Not_constant -> - Lprim(Pmakearray (kind, Mutable), ll) + Lprim(Pmakearray (kind, Mutable), ll, e.exp_loc) end | Texp_ifthenelse(cond, ifso, Some ifnot) -> Lifthenelse(transl_exp cond, @@ -932,18 +989,18 @@ and transl_exp0 e = | Texp_new (cl, {Location.loc=loc}, _) -> Lapply{ap_should_be_tailcall=false; ap_loc=loc; - ap_func=Lprim(Pfield 0, [transl_path ~loc e.exp_env cl]); + ap_func=Lprim(Pfield 0, [transl_path ~loc e.exp_env cl], loc); ap_args=[lambda_unit]; ap_inlined=Default_inline; ap_specialised=Default_specialise} | Texp_instvar(path_self, path, _) -> Lprim(Parrayrefu Paddrarray, - [transl_normal_path path_self; transl_normal_path path]) + [transl_normal_path path_self; transl_normal_path path], e.exp_loc) | Texp_setinstvar(path_self, path, _, expr) -> - transl_setinstvar (transl_normal_path path_self) path expr + transl_setinstvar e.exp_loc (transl_normal_path path_self) path expr | Texp_override(path_self, modifs) -> let cpy = Ident.create "copy" in - Llet(Strict, cpy, + Llet(Strict, Pgenval, cpy, Lapply{ap_should_be_tailcall=false; ap_loc=Location.none; ap_func=Translobj.oo_prim "copy"; @@ -952,11 +1009,18 @@ and transl_exp0 e = ap_specialised=Default_specialise}, List.fold_right (fun (path, _, expr) rem -> - Lsequence(transl_setinstvar (Lvar cpy) path expr, rem)) + Lsequence(transl_setinstvar Location.none + (Lvar cpy) path expr, rem)) modifs (Lvar cpy)) | Texp_letmodule(id, _, modl, body) -> - Llet(Strict, id, !transl_module Tcoerce_none None modl, transl_exp body) + Llet(Strict, Pgenval, id, + !transl_module Tcoerce_none None modl, + transl_exp body) + | Texp_letexception(cd, body) -> + Llet(Strict, Pgenval, + cd.ext_id, transl_extension_constructor e.exp_env None cd, + transl_exp body) | Texp_pack modl -> !transl_module Tcoerce_none None modl | Texp_assert {exp_desc=Texp_construct(_, {cstr_name="false"}, _)} -> @@ -978,43 +1042,31 @@ and transl_exp0 e = | Texp_construct (_, {cstr_arity = 0}, _) -> transl_exp e | Texp_constant(Const_float _) -> - Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e]) - | Texp_ident(_, _, _) -> (* according to the type *) - begin match e.exp_type.desc with - (* the following may represent a float/forward/lazy: need a - forward_tag *) - | Tvar _ | Tlink _ | Tsubst _ | Tunivar _ - | Tpoly(_,_) | Tfield(_,_,_,_) -> - Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e]) - (* the following cannot be represented as float/forward/lazy: - optimize *) - | Tarrow(_,_,_,_) | Ttuple _ | Tpackage _ | Tobject(_,_) | Tnil - | Tvariant _ - -> transl_exp e - (* optimize predefined types (excepted float) *) - | Tconstr(_,_,_) -> - if has_base_type e Predef.path_int - || has_base_type e Predef.path_char - || has_base_type e Predef.path_string - || has_base_type e Predef.path_bool - || has_base_type e Predef.path_unit - || has_base_type e Predef.path_exn - || has_base_type e Predef.path_array - || has_base_type e Predef.path_list - || has_base_type e Predef.path_option - || has_base_type e Predef.path_nativeint - || has_base_type e Predef.path_int32 - || has_base_type e Predef.path_int64 - then transl_exp e - else - Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e]) - end + (* We don't need to wrap with Popaque: this forward + block will never be shortcutted since it points to a float. *) + Lprim(Pmakeblock(Obj.forward_tag, Immutable, None), + [transl_exp e], e.exp_loc) + | Texp_ident _ -> + (* CR-someday mshinwell: Consider adding a new primitive + that expresses the construction of forward_tag blocks. + We need to use [Popaque] here to prevent unsound + optimisation in Flambda, but the concept of a mutable + block doesn't really match what is going on here. This + value may subsequently turn into an immediate... *) + if Typeopt.lazy_val_requires_forward e.exp_env e.exp_type + then + Lprim (Popaque, + [Lprim(Pmakeblock(Obj.forward_tag, Immutable, None), + [transl_exp e], e.exp_loc)], + e.exp_loc) + else transl_exp e (* other cases compile to a lazy block holding a function *) | _ -> let fn = Lfunction {kind = Curried; params = [Ident.create "param"]; attr = default_function_attribute; + loc = e.exp_loc; body = transl_exp e} in - Lprim(Pmakeblock(Config.lazy_tag, Mutable), [fn]) + Lprim(Pmakeblock(Config.lazy_tag, Mutable, None), [fn], e.exp_loc) end | Texp_object (cs, meths) -> let cty = cs.cstr_type in @@ -1032,6 +1084,13 @@ and transl_exp0 e = and transl_list expr_list = List.map transl_exp expr_list +and transl_list_with_shape expr_list = + let transl_with_shape e = + let shape = Typeopt.value_kind e.exp_env e.exp_type in + transl_exp e, shape + in + List.split (List.map transl_with_shape expr_list) + and transl_guard guard rhs = let expr = event_before rhs (transl_exp rhs) in match guard with @@ -1109,17 +1168,19 @@ and transl_apply ?(should_be_tailcall=false) ?(inlined = Default_inline) and id_arg = Ident.create "param" in let body = match build_apply handle ((Lvar id_arg, optional)::args') l with - Lfunction{kind = Curried; params = ids; body = lam; attr} -> - Lfunction{kind = Curried; params = id_arg::ids; body = lam; attr} + Lfunction{kind = Curried; params = ids; body = lam; attr; loc} -> + Lfunction{kind = Curried; params = id_arg::ids; body = lam; attr; + loc} | Levent(Lfunction{kind = Curried; params = ids; - body = lam; attr}, _) -> - Lfunction{kind = Curried; params = id_arg::ids; body = lam; attr} + body = lam; attr; loc}, _) -> + Lfunction{kind = Curried; params = id_arg::ids; body = lam; attr; + loc} | lam -> Lfunction{kind = Curried; params = [id_arg]; body = lam; - attr = default_function_attribute} + attr = default_function_attribute; loc = loc} in List.fold_left - (fun body (id, lam) -> Llet(Strict, id, lam, body)) + (fun body (id, lam) -> Llet(Strict, Pgenval, id, lam, body)) body !defs | (Some arg, optional) :: l -> build_apply lam ((arg, optional) :: args) l @@ -1149,7 +1210,7 @@ and transl_function loc untuplify_fn repr partial cases = (fun {c_lhs; c_guard; c_rhs} -> (Matching.flatten_pattern size c_lhs, c_guard, c_rhs)) cases in - let params = List.map (fun p -> Ident.create "param") pl in + let params = List.map (fun _ -> Ident.create "param") pl in ((Tupled, params), Matching.for_tupled_function loc params (transl_tupled_cases pats_expr_list) partial) @@ -1189,7 +1250,7 @@ and transl_let rec_flag pat_expr_list body = | Tpat_alias ({pat_desc=Tpat_any}, id,_) -> id | _ -> raise(Error(pat.pat_loc, Illegal_letrec_pat))) pat_expr_list in - let transl_case {vb_pat=pat; vb_expr=expr; vb_attributes; vb_loc} id = + let transl_case {vb_expr=expr; vb_attributes; vb_loc} id = let lam = transl_exp expr in let lam = Translattribute.add_inline_attribute lam vb_loc @@ -1204,42 +1265,45 @@ and transl_let rec_flag pat_expr_list body = (id, lam) in Lletrec(List.map2 transl_case pat_expr_list idlist, body) -and transl_setinstvar self var expr = +and transl_setinstvar loc self var expr = let prim = match maybe_pointer expr with | Pointer -> Paddrarray | Immediate -> Pintarray in - Lprim(Parraysetu prim, [self; transl_normal_path var; transl_exp expr]) - -and transl_record env all_labels repres lbl_expr_list opt_init_expr = - let size = Array.length all_labels in - (* Determine if there are "enough" new fields *) - if 3 + 2 * List.length lbl_expr_list >= size + Lprim(Parraysetu prim, [self; transl_normal_path var; transl_exp expr], loc) + +and transl_record loc env fields repres opt_init_expr = + let size = Array.length fields in + (* Determine if there are "enough" fields (only relevant if this is a + functional-style record update *) + let no_init = match opt_init_expr with None -> true | _ -> false in + if no_init || size < Config.max_young_wosize then begin (* Allocate new record with given fields (and remaining fields taken from init_expr if any *) - let lv = Array.make (Array.length all_labels) staticfail in let init_id = Ident.create "init" in - begin match opt_init_expr with - None -> () - | Some init_expr -> - for i = 0 to Array.length all_labels - 1 do - let access = - match all_labels.(i).lbl_repres with - Record_regular | Record_inlined _ -> Pfield i - | Record_extension -> Pfield (i + 1) - | Record_float -> Pfloatfield i in - lv.(i) <- Lprim(access, [Lvar init_id]) - done - end; - List.iter - (fun (_, lbl, expr) -> lv.(lbl.lbl_pos) <- transl_exp expr) - lbl_expr_list; - let ll = Array.to_list lv in + let lv = + Array.mapi + (fun i (_, definition) -> + match definition with + | Kept typ -> + let field_kind = value_kind env typ in + let access = + match repres with + Record_regular | Record_inlined _ -> Pfield i + | Record_unboxed _ -> assert false + | Record_extension -> Pfield (i + 1) + | Record_float -> Pfloatfield i in + Lprim(access, [Lvar init_id], loc), field_kind + | Overridden (_lid, expr) -> + let field_kind = value_kind expr.exp_env expr.exp_type in + transl_exp expr, field_kind) + fields + in + let ll, shape = List.split (Array.to_list lv) in let mut = - if List.exists (fun lbl -> lbl.lbl_mut = Mutable) - (Array.to_list all_labels) + if Array.exists (fun (lbl, _) -> lbl.lbl_mut = Mutable) fields then Mutable else Immutable in let lam = @@ -1249,27 +1313,34 @@ and transl_record env all_labels repres lbl_expr_list opt_init_expr = match repres with | Record_regular -> Lconst(Const_block(0, cl)) | Record_inlined tag -> Lconst(Const_block(tag, cl)) + | Record_unboxed _ -> Lconst(match cl with [v] -> v | _ -> assert false) | Record_float -> Lconst(Const_float_array(List.map extract_float cl)) | Record_extension -> raise Not_constant with Not_constant -> match repres with - Record_regular -> Lprim(Pmakeblock(0, mut), ll) - | Record_inlined tag -> Lprim(Pmakeblock(tag, mut), ll) - | Record_float -> Lprim(Pmakearray (Pfloatarray, mut), ll) + Record_regular -> + Lprim(Pmakeblock(0, mut, Some shape), ll, loc) + | Record_inlined tag -> + Lprim(Pmakeblock(tag, mut, Some shape), ll, loc) + | Record_unboxed _ -> (match ll with [v] -> v | _ -> assert false) + | Record_float -> + Lprim(Pmakearray (Pfloatarray, mut), ll, loc) | Record_extension -> let path = - match all_labels.(0).lbl_res.desc with + let (label, _) = fields.(0) in + match label.lbl_res.desc with | Tconstr(p, _, _) -> p | _ -> assert false in let slot = transl_path env path in - Lprim(Pmakeblock(0, mut), slot :: ll) + Lprim(Pmakeblock(0, mut, Some (Pgenval :: shape)), slot :: ll, loc) in begin match opt_init_expr with None -> lam - | Some init_expr -> Llet(Strict, init_id, transl_exp init_expr, lam) + | Some init_expr -> Llet(Strict, Pgenval, init_id, + transl_exp init_expr, lam) end end else begin (* Take a shallow copy of the init record, then mutate the fields @@ -1277,23 +1348,28 @@ and transl_record env all_labels repres lbl_expr_list opt_init_expr = (* If you change anything here, you will likely have to change [check_recursive_recordwith] in this file. *) let copy_id = Ident.create "newrecord" in - let update_field (_, lbl, expr) cont = - let upd = - match lbl.lbl_repres with - Record_regular - | Record_inlined _ -> - Psetfield(lbl.lbl_pos, maybe_pointer expr, Assignment) - | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment) - | Record_extension -> - Psetfield(lbl.lbl_pos + 1, maybe_pointer expr, Assignment) - in - Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr]), cont) in + let update_field cont (lbl, definition) = + match definition with + | Kept _type -> cont + | Overridden (_lid, expr) -> + let upd = + match repres with + Record_regular + | Record_inlined _ -> + Psetfield(lbl.lbl_pos, maybe_pointer expr, Assignment) + | Record_unboxed _ -> assert false + | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment) + | Record_extension -> + Psetfield(lbl.lbl_pos + 1, maybe_pointer expr, Assignment) + in + Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr], loc), cont) + in begin match opt_init_expr with None -> assert false | Some init_expr -> - Llet(Strict, copy_id, - Lprim(Pduprecord (repres, size), [transl_exp init_expr]), - List.fold_right update_field lbl_expr_list (Lvar copy_id)) + Llet(Strict, Pgenval, copy_id, + Lprim(Pduprecord (repres, size), [transl_exp init_expr], loc), + Array.fold_left update_field (Lvar copy_id) fields) end end diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli index 16f2c895..fb5a5060 100644 --- a/bytecomp/translcore.mli +++ b/bytecomp/translcore.mli @@ -30,6 +30,9 @@ val transl_let: rec_flag -> value_binding list -> lambda -> lambda val transl_primitive: Location.t -> Primitive.description -> Env.t -> Types.type_expr -> Path.t option -> lambda +val transl_extension_constructor: Env.t -> Path.t option -> + extension_constructor -> lambda + val check_recursive_lambda: Ident.t list -> lambda -> bool val used_primitives: (Path.t, Location.t) Hashtbl.t diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index 52b744c4..f2f6263a 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -48,60 +48,44 @@ let field_path path field = (* Compile type extensions *) -let prim_fresh_oo_id = - Pccall (Primitive.simple ~name:"caml_fresh_oo_id" ~arity:1 ~alloc:false) - -let transl_extension_constructor env path ext = - let name = - match path, !Clflags.for_package with - None, _ -> Ident.name ext.ext_id - | Some p, None -> Path.name p - | Some p, Some pack -> Printf.sprintf "%s.%s" pack (Path.name p) - in - match ext.ext_kind with - Text_decl(args, ret) -> - Lprim (Pmakeblock (Obj.object_tag, Immutable), - [Lconst (Const_base (Const_string (name, None))); - Lprim (prim_fresh_oo_id, [Lconst (Const_base (Const_int 0))])]) - | Text_rebind(path, lid) -> - transl_path ~loc:ext.ext_loc env path - let transl_type_extension env rootpath tyext body = List.fold_right (fun ext body -> let lam = transl_extension_constructor env (field_path rootpath ext.ext_id) ext in - Llet(Strict, ext.ext_id, lam, body)) + Llet(Strict, Pgenval, ext.ext_id, lam, body)) tyext.tyext_constructors body (* Compile a coercion *) -let rec apply_coercion strict restr arg = +let rec apply_coercion loc strict restr arg = match restr with Tcoerce_none -> arg | Tcoerce_structure(pos_cc_list, id_pos_list) -> name_lambda strict arg (fun id -> - let get_field pos = Lprim(Pfield pos,[Lvar id]) in + let get_field pos = Lprim(Pfield pos,[Lvar id], loc) in let lam = - Lprim(Pmakeblock(0, Immutable), - List.map (apply_coercion_field get_field) pos_cc_list) + Lprim(Pmakeblock(0, Immutable, None), + List.map (apply_coercion_field loc get_field) pos_cc_list, + loc) in - wrap_id_pos_list id_pos_list get_field lam) + wrap_id_pos_list loc id_pos_list get_field lam) | Tcoerce_functor(cc_arg, cc_res) -> let param = Ident.create "funarg" in name_lambda strict arg (fun id -> Lfunction{kind = Curried; params = [param]; attr = { default_function_attribute with is_a_functor = true }; + loc = loc; body = apply_coercion - Strict cc_res + loc Strict cc_res (Lapply{ap_should_be_tailcall=false; - ap_loc=Location.none; + ap_loc=loc; ap_func=Lvar id; - ap_args=[apply_coercion Alias cc_arg + ap_args=[apply_coercion loc Alias cc_arg (Lvar param)]; ap_inlined=Default_inline; ap_specialised=Default_specialise})}) @@ -109,12 +93,12 @@ let rec apply_coercion strict restr arg = transl_primitive pc_loc pc_desc pc_env pc_type None | Tcoerce_alias (path, cc) -> name_lambda strict arg - (fun id -> apply_coercion Alias cc (transl_normal_path path)) + (fun _ -> apply_coercion loc Alias cc (transl_normal_path path)) -and apply_coercion_field get_field (pos, cc) = - apply_coercion Alias cc (get_field pos) +and apply_coercion_field loc get_field (pos, cc) = + apply_coercion loc Alias cc (get_field pos) -and wrap_id_pos_list id_pos_list get_field lam = +and wrap_id_pos_list loc id_pos_list get_field lam = let fv = free_variables lam in (*Format.eprintf "%a@." Printlambda.lambda lam; IdentSet.iter (fun id -> Format.eprintf "%a " Ident.print id) fv; @@ -123,8 +107,8 @@ and wrap_id_pos_list id_pos_list get_field lam = List.fold_left (fun (lam,s) (id',pos,c) -> if IdentSet.mem id' fv then let id'' = Ident.create (Ident.name id') in - (Llet(Alias,id'', - apply_coercion Alias c (get_field pos),lam), + (Llet(Alias, Pgenval, id'', + apply_coercion loc Alias c (get_field pos),lam), Ident.add id' (Lvar id'') s) else (lam,s)) (lam, Ident.empty) id_pos_list @@ -210,7 +194,7 @@ let init_shape modl = Const_block (1, [Const_pointer 0]) | Mty_signature sg -> Const_block(0, [Const_block(0, init_shape_struct env sg)]) - | Mty_functor(id, arg, res) -> + | Mty_functor _ -> raise Not_found (* can we do better? *) and init_shape_struct env sg = match sg with @@ -230,17 +214,18 @@ let init_shape modl = assert false | Sig_type(id, tdecl, _) :: rem -> init_shape_struct (Env.add_type ~check:false id tdecl env) rem - | Sig_typext(id, ext, _) :: rem -> + | Sig_typext _ :: _ -> raise Not_found | Sig_module(id, md, _) :: rem -> init_shape_mod env md.md_type :: - init_shape_struct (Env.add_module_declaration id md env) rem + init_shape_struct (Env.add_module_declaration ~check:false + id md env) rem | Sig_modtype(id, minfo) :: rem -> init_shape_struct (Env.add_modtype id minfo env) rem - | Sig_class(id, cdecl, _) :: rem -> + | Sig_class _ :: rem -> Const_pointer 2 (* camlinternalMod.Class *) :: init_shape_struct env rem - | Sig_class_type(id, ctyp, _) :: rem -> + | Sig_class_type _ :: rem -> init_shape_struct env rem in try @@ -289,10 +274,10 @@ let eval_rec_bindings bindings cont = let rec bind_inits = function [] -> bind_strict bindings - | (id, None, rhs) :: rem -> + | (_id, None, _rhs) :: rem -> bind_inits rem - | (id, Some(loc, shape), rhs) :: rem -> - Llet(Strict, id, + | (id, Some(loc, shape), _rhs) :: rem -> + Llet(Strict, Pgenval, id, Lapply{ap_should_be_tailcall=false; ap_loc=Location.none; ap_func=mod_prim "init_mod"; @@ -304,15 +289,15 @@ let eval_rec_bindings bindings cont = [] -> patch_forwards bindings | (id, None, rhs) :: rem -> - Llet(Strict, id, rhs, bind_strict rem) - | (id, Some(loc, shape), rhs) :: rem -> + Llet(Strict, Pgenval, id, rhs, bind_strict rem) + | (_id, Some _, _rhs) :: rem -> bind_strict rem and patch_forwards = function [] -> cont - | (id, None, rhs) :: rem -> + | (_id, None, _rhs) :: rem -> patch_forwards rem - | (id, Some(loc, shape), rhs) :: rem -> + | (id, Some(_loc, shape), rhs) :: rem -> Lsequence(Lapply{ap_should_be_tailcall=false; ap_loc=Location.none; ap_func=mod_prim "update_mod"; @@ -341,9 +326,9 @@ let rec bound_value_identifiers = function [] -> [] | Sig_value(id, {val_kind = Val_reg}) :: rem -> id :: bound_value_identifiers rem - | Sig_typext(id, ext, _) :: rem -> id :: bound_value_identifiers rem - | Sig_module(id, mty, _) :: rem -> id :: bound_value_identifiers rem - | Sig_class(id, decl, _) :: rem -> id :: bound_value_identifiers rem + | Sig_typext(id, _, _) :: rem -> id :: bound_value_identifiers rem + | Sig_module(id, _, _) :: rem -> id :: bound_value_identifiers rem + | Sig_class(id, _, _) :: rem -> id :: bound_value_identifiers rem | _ :: rem -> bound_value_identifiers rem @@ -362,16 +347,17 @@ let transl_class_bindings cl_list = let rec transl_module cc rootpath mexp = List.iter (Translattribute.check_attribute_on_module mexp) mexp.mod_attributes; + let loc = mexp.mod_loc in match mexp.mod_type with - Mty_alias _ -> apply_coercion Alias cc lambda_unit + Mty_alias _ -> apply_coercion loc Alias cc lambda_unit | _ -> match mexp.mod_desc with Tmod_ident (path,_) -> - apply_coercion Strict cc - (transl_path ~loc:mexp.mod_loc mexp.mod_env path) + apply_coercion loc Strict cc + (transl_path ~loc mexp.mod_env path) | Tmod_structure str -> - fst (transl_struct [] cc rootpath str) - | Tmod_functor( param, _, mty, body) -> + fst (transl_struct loc [] cc rootpath str) + | Tmod_functor(param, _, _, body) -> let bodypath = functor_path rootpath param in let inline_attribute = Translattribute.get_inline_attribute mexp.mod_attributes @@ -383,6 +369,7 @@ let rec transl_module cc rootpath mexp = attr = { inline = inline_attribute; specialise = Default_specialise; is_a_functor = true }; + loc = loc; body = transl_module Tcoerce_none bodypath body} | Tcoerce_functor(ccarg, ccres) -> let param' = Ident.create "funarg" in @@ -390,8 +377,9 @@ let rec transl_module cc rootpath mexp = attr = { inline = inline_attribute; specialise = Default_specialise; is_a_functor = true }; - body = Llet(Alias, param, - apply_coercion Alias ccarg + loc = loc; + body = Llet(Alias, Pgenval, param, + apply_coercion loc Alias ccarg (Lvar param'), transl_module ccres bodypath body)} | _ -> @@ -402,28 +390,28 @@ let rec transl_module cc rootpath mexp = Translattribute.get_and_remove_inlined_attribute_on_module funct in oo_wrap mexp.mod_env true - (apply_coercion Strict cc) + (apply_coercion loc Strict cc) (Lapply{ap_should_be_tailcall=false; - ap_loc=mexp.mod_loc; + ap_loc=loc; ap_func=transl_module Tcoerce_none None funct; ap_args=[transl_module ccarg None arg]; ap_inlined=inlined_attribute; ap_specialised=Default_specialise}) - | Tmod_constraint(arg, mty, _, ccarg) -> + | Tmod_constraint(arg, _, _, ccarg) -> transl_module (compose_coercions cc ccarg) rootpath arg | Tmod_unpack(arg, _) -> - apply_coercion Strict cc (Translcore.transl_exp arg) + apply_coercion loc Strict cc (Translcore.transl_exp arg) -and transl_struct fields cc rootpath str = - transl_structure fields cc rootpath str.str_final_env str.str_items +and transl_struct loc fields cc rootpath str = + transl_structure loc fields cc rootpath str.str_final_env str.str_items -and transl_structure fields cc rootpath final_env = function +and transl_structure loc fields cc rootpath final_env = function [] -> let body, size = match cc with Tcoerce_none -> - Lprim(Pmakeblock(0, Immutable), - List.map (fun id -> Lvar id) (List.rev fields)), + Lprim(Pmakeblock(0, Immutable, None), + List.map (fun id -> Lvar id) (List.rev fields), loc), List.length fields | Tcoerce_structure(pos_cc_list, id_pos_list) -> (* Do not ignore id_pos_list ! *) @@ -435,20 +423,20 @@ and transl_structure fields cc rootpath final_env = function let get_field pos = Lvar v.(pos) and ids = List.fold_right IdentSet.add fields IdentSet.empty in let lam = - (Lprim(Pmakeblock(0, Immutable), + Lprim(Pmakeblock(0, Immutable, None), List.map (fun (pos, cc) -> match cc with Tcoerce_primitive p -> transl_primitive p.pc_loc p.pc_desc p.pc_env p.pc_type None - | _ -> apply_coercion Strict cc (get_field pos)) - pos_cc_list)) + | _ -> apply_coercion loc Strict cc (get_field pos)) + pos_cc_list, loc) and id_pos_list = List.filter (fun (id,_,_) -> not (IdentSet.mem id ids)) id_pos_list in - wrap_id_pos_list id_pos_list get_field lam, + wrap_id_pos_list loc id_pos_list get_field lam, List.length pos_cc_list | _ -> fatal_error "Translmod.transl_structure" @@ -456,9 +444,9 @@ and transl_structure fields cc rootpath final_env = function (* This debugging event provides information regarding the structure items. It is ignored by the OCaml debugger but is used by Js_of_ocaml to preserve variable names. *) - (if !Clflags.debug then + (if !Clflags.debug && not !Clflags.native_code then Levent(body, - {lev_loc = Location.none; + {lev_loc = loc; lev_kind = Lev_pseudo; lev_repr = None; lev_env = Env.summary final_env}) @@ -468,22 +456,25 @@ and transl_structure fields cc rootpath final_env = function | item :: rem -> match item.str_desc with | Tstr_eval (expr, _) -> - let body, size = transl_structure fields cc rootpath final_env rem in + let body, size = + transl_structure loc fields cc rootpath final_env rem + in Lsequence(transl_exp expr, body), size | Tstr_value(rec_flag, pat_expr_list) -> let ext_fields = rev_let_bound_idents pat_expr_list @ fields in let body, size = - transl_structure ext_fields cc rootpath final_env rem in + transl_structure loc ext_fields cc rootpath final_env rem + in transl_let rec_flag pat_expr_list body, size | Tstr_primitive descr -> record_primitive descr.val_val; - transl_structure fields cc rootpath final_env rem - | Tstr_type(_, decls) -> - transl_structure fields cc rootpath final_env rem + transl_structure loc fields cc rootpath final_env rem + | Tstr_type _ -> + transl_structure loc fields cc rootpath final_env rem | Tstr_typext(tyext) -> let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in let body, size = - transl_structure (List.rev_append ids fields) + transl_structure loc (List.rev_append ids fields) cc rootpath final_env rem in transl_type_extension item.str_env rootpath tyext body, size @@ -491,13 +482,16 @@ and transl_structure fields cc rootpath final_env = function let id = ext.ext_id in let path = field_path rootpath id in let body, size = - transl_structure (id :: fields) cc rootpath final_env rem in - Llet(Strict, id, transl_extension_constructor item.str_env path ext, - body), size + transl_structure loc (id :: fields) cc rootpath final_env rem + in + Llet(Strict, Pgenval, id, + transl_extension_constructor item.str_env path ext, body), + size | Tstr_module mb -> let id = mb.mb_id in let body, size = - transl_structure (id :: fields) cc rootpath final_env rem in + transl_structure loc (id :: fields) cc rootpath final_env rem + in let module_body = transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr in @@ -505,7 +499,7 @@ and transl_structure fields cc rootpath final_env = function Translattribute.add_inline_attribute module_body mb.mb_loc mb.mb_attributes in - Llet(pure_module mb.mb_expr, id, + Llet(pure_module mb.mb_expr, Pgenval, id, module_body, body), size | Tstr_recmodule bindings -> @@ -513,7 +507,8 @@ and transl_structure fields cc rootpath final_env = function List.rev_append (List.map (fun mb -> mb.mb_id) bindings) fields in let body, size = - transl_structure ext_fields cc rootpath final_env rem in + transl_structure loc ext_fields cc rootpath final_env rem + in let lam = compile_recmodule (fun id modl -> @@ -525,7 +520,7 @@ and transl_structure fields cc rootpath final_env = function | Tstr_class cl_list -> let (ids, class_bindings) = transl_class_bindings cl_list in let body, size = - transl_structure (List.rev_append ids fields) + transl_structure loc (List.rev_append ids fields) cc rootpath final_env rem in Lletrec(class_bindings, body), size @@ -535,22 +530,25 @@ and transl_structure fields cc rootpath final_env = function let mid = Ident.create "include" in let rec rebind_idents pos newfields = function [] -> - transl_structure newfields cc rootpath final_env rem + transl_structure loc newfields cc rootpath final_env rem | id :: ids -> let body, size = rebind_idents (pos + 1) (id :: newfields) ids in - Llet(Alias, id, Lprim(Pfield pos, [Lvar mid]), body), size + Llet(Alias, Pgenval, id, + Lprim(Pfield pos, [Lvar mid], incl.incl_loc), body), + size in let body, size = rebind_idents 0 fields ids in - Llet(pure_module modl, mid, transl_module Tcoerce_none None modl, - body), size + Llet(pure_module modl, Pgenval, mid, + transl_module Tcoerce_none None modl, body), + size | Tstr_modtype _ | Tstr_open _ | Tstr_class_type _ | Tstr_attribute _ -> - transl_structure fields cc rootpath final_env rem + transl_structure loc fields cc rootpath final_env rem and pure_module m = match m.mod_desc with @@ -565,41 +563,35 @@ let _ = (* Introduce dependencies on modules referenced only by "external". *) let scan_used_globals lam = - let globals = ref IdentSet.empty in + let globals = ref Ident.Set.empty in let rec scan lam = Lambda.iter scan lam; match lam with - Lprim ((Pgetglobal id | Psetglobal id), _) -> - globals := IdentSet.add id !globals + Lprim ((Pgetglobal id | Psetglobal id), _, _) -> + globals := Ident.Set.add id !globals | _ -> () in scan lam; !globals -let wrap_globals ~flambda body = +let required_globals ~flambda body = let globals = scan_used_globals body in let add_global id req = - if not flambda && IdentSet.mem id globals then + if not flambda && Ident.Set.mem id globals then req else - IdentSet.add id req + Ident.Set.add id req in let required = Hashtbl.fold - (fun path loc -> add_global (Path.head path)) used_primitives - (if flambda then globals else IdentSet.empty) + (fun path _ -> add_global (Path.head path)) used_primitives + (if flambda then globals else Ident.Set.empty) in let required = List.fold_right add_global (Env.get_required_globals ()) required in Env.reset_required_globals (); Hashtbl.clear used_primitives; - IdentSet.fold - (fun id expr -> Lsequence(Lprim(Popaque, [Lprim(Pgetglobal id, [])]), expr)) - required body - (* Location.prerr_warning loc - (Warnings.Nonrequired_global (Ident.name (Path.head path), - "uses the primitive " ^ - Printtyp.string_of_path path))) *) + required (* Compile an implementation *) @@ -610,15 +602,23 @@ let transl_implementation_flambda module_name (str, cc) = let module_id = Ident.create_persistent module_name in let body, size = Translobj.transl_label_init - (fun () -> transl_struct [] cc (global_path module_id) str) + (fun () -> transl_struct Location.none [] cc + (global_path module_id) str) in - (module_id, size), wrap_globals ~flambda:true body + { module_ident = module_id; + main_module_block_size = size; + required_globals = required_globals ~flambda:true body; + code = body } let transl_implementation module_name (str, cc) = - let (module_id, _size), module_initializer = + let implementation = transl_implementation_flambda module_name (str, cc) in - Lprim (Psetglobal module_id, [module_initializer]) + let code = + Lprim (Psetglobal implementation.module_ident, [implementation.code], + Location.none) + in + { implementation with code } (* Build the list of value identifiers defined by a toplevel structure (excluding primitive declarations). *) @@ -627,11 +627,11 @@ let rec defined_idents = function [] -> [] | item :: rem -> match item.str_desc with - | Tstr_eval (expr, _) -> defined_idents rem - | Tstr_value(rec_flag, pat_expr_list) -> + | Tstr_eval _ -> defined_idents rem + | Tstr_value(_rec_flag, pat_expr_list) -> let_bound_idents pat_expr_list @ defined_idents rem - | Tstr_primitive desc -> defined_idents rem - | Tstr_type (_, decls) -> defined_idents rem + | Tstr_primitive _ -> defined_idents rem + | Tstr_type _ -> defined_idents rem | Tstr_typext tyext -> List.map (fun ext -> ext.ext_id) tyext.tyext_constructors @ defined_idents rem @@ -643,7 +643,7 @@ let rec defined_idents = function | Tstr_open _ -> defined_idents rem | Tstr_class cl_list -> List.map (fun (ci, _) -> ci.ci_id_class) cl_list @ defined_idents rem - | Tstr_class_type cl_list -> defined_idents rem + | Tstr_class_type _ -> defined_idents rem | Tstr_include incl -> bound_value_identifiers incl.incl_type @ defined_idents rem | Tstr_attribute _ -> defined_idents rem @@ -654,17 +654,17 @@ let rec more_idents = function [] -> [] | item :: rem -> match item.str_desc with - | Tstr_eval (expr, _attrs) -> more_idents rem - | Tstr_value(rec_flag, pat_expr_list) -> more_idents rem + | Tstr_eval _ -> more_idents rem + | Tstr_value _ -> more_idents rem | Tstr_primitive _ -> more_idents rem - | Tstr_type (_, decls) -> more_idents rem - | Tstr_typext tyext -> more_idents rem + | Tstr_type _ -> more_idents rem + | Tstr_typext _ -> more_idents rem | Tstr_exception _ -> more_idents rem - | Tstr_recmodule decls -> more_idents rem + | Tstr_recmodule _ -> more_idents rem | Tstr_modtype _ -> more_idents rem | Tstr_open _ -> more_idents rem - | Tstr_class cl_list -> more_idents rem - | Tstr_class_type cl_list -> more_idents rem + | Tstr_class _ -> more_idents rem + | Tstr_class_type _ -> more_idents rem | Tstr_include _ -> more_idents rem | Tstr_module {mb_expr={mod_desc = Tmod_structure str}} | Tstr_module{mb_expr={mod_desc = @@ -678,11 +678,11 @@ and all_idents = function [] -> [] | item :: rem -> match item.str_desc with - | Tstr_eval (expr, _attrs) -> all_idents rem - | Tstr_value(rec_flag, pat_expr_list) -> + | Tstr_eval _ -> all_idents rem + | Tstr_value(_rec_flag, pat_expr_list) -> let_bound_idents pat_expr_list @ all_idents rem | Tstr_primitive _ -> all_idents rem - | Tstr_type (_, decls) -> all_idents rem + | Tstr_type _ -> all_idents rem | Tstr_typext tyext -> List.map (fun ext -> ext.ext_id) tyext.tyext_constructors @ all_idents rem @@ -693,7 +693,7 @@ and all_idents = function | Tstr_open _ -> all_idents rem | Tstr_class cl_list -> List.map (fun (ci, _) -> ci.ci_id_class) cl_list @ all_idents rem - | Tstr_class_type cl_list -> all_idents rem + | Tstr_class_type _ -> all_idents rem | Tstr_include incl -> bound_value_identifiers incl.incl_type @ all_idents rem | Tstr_module {mb_id;mb_expr={mod_desc = Tmod_structure str}} @@ -721,7 +721,7 @@ let transl_store_subst = ref Ident.empty let nat_toplevel_name id = try match Ident.find_same id !transl_store_subst with - | Lprim(Pfield pos, [Lprim(Pgetglobal glob, [])]) -> (glob,pos) + | Lprim(Pfield pos, [Lprim(Pgetglobal glob, [], _)], _) -> (glob,pos) | _ -> raise Not_found with Not_found -> fatal_error("Translmod.nat_toplevel_name: " ^ Ident.unique_name id) @@ -738,13 +738,15 @@ let transl_store_structure glob map prims str = transl_store rootpath subst rem) | Tstr_value(rec_flag, pat_expr_list) -> let ids = let_bound_idents pat_expr_list in - let lam = transl_let rec_flag pat_expr_list (store_idents ids) in + let lam = + transl_let rec_flag pat_expr_list (store_idents Location.none ids) + in Lsequence(subst_lambda subst lam, transl_store rootpath (add_idents false ids subst) rem) | Tstr_primitive descr -> record_primitive descr.val_val; transl_store rootpath subst rem - | Tstr_type(_, decls) -> + | Tstr_type _ -> transl_store rootpath subst rem | Tstr_typext(tyext) -> let ids = @@ -752,7 +754,7 @@ let transl_store_structure glob map prims str = in let lam = transl_type_extension item.str_env rootpath tyext - (store_idents ids) + (store_idents Location.none ids) in Lsequence(subst_lambda subst lam, transl_store rootpath (add_idents false ids subst) rem) @@ -760,9 +762,10 @@ let transl_store_structure glob map prims str = let id = ext.ext_id in let path = field_path rootpath id in let lam = transl_extension_constructor item.str_env path ext in - Lsequence(Llet(Strict, id, subst_lambda subst lam, store_ident id), + Lsequence(Llet(Strict, Pgenval, id, subst_lambda subst lam, + store_ident ext.ext_loc id), transl_store rootpath (add_ident false id subst) rem) - | Tstr_module{mb_id=id; + | Tstr_module{mb_id=id;mb_loc=loc; mb_expr={mod_desc = Tmod_structure str} as mexp; mb_attributes} -> List.iter (Translattribute.check_attribute_on_module mexp) @@ -773,17 +776,17 @@ let transl_store_structure glob map prims str = (* Careful: see next case *) let subst = !transl_store_subst in Lsequence(lam, - Llet(Strict, id, + Llet(Strict, Pgenval, id, subst_lambda subst - (Lprim(Pmakeblock(0, Immutable), + (Lprim(Pmakeblock(0, Immutable, None), List.map (fun id -> Lvar id) - (defined_idents str.str_items))), - Lsequence(store_ident id, + (defined_idents str.str_items), loc)), + Lsequence(store_ident loc id, transl_store rootpath (add_ident true id subst) rem))) | Tstr_module{ - mb_id=id; + mb_id=id;mb_loc=loc; mb_expr= { mod_desc = Tmod_constraint ( {mod_desc = Tmod_structure str} as mexp, _, _, @@ -804,22 +807,22 @@ let transl_store_structure glob map prims str = match cc with | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } -> transl_primitive pc_loc pc_desc pc_env pc_type None - | _ -> apply_coercion Strict cc (Lvar ids.(pos)) + | _ -> apply_coercion loc Strict cc (Lvar ids.(pos)) in Lsequence(lam, - Llet(Strict, id, + Llet(Strict, Pgenval, id, subst_lambda subst - (Lprim(Pmakeblock(0, Immutable), - List.map field map)), - Lsequence(store_ident id, + (Lprim(Pmakeblock(0, Immutable, None), + List.map field map, loc)), + Lsequence(store_ident loc id, transl_store rootpath (add_ident true id subst) rem))) - | Tstr_module{mb_id=id; mb_expr=modl; mb_loc; mb_attributes} -> + | Tstr_module{mb_id=id; mb_expr=modl; mb_loc=loc; mb_attributes} -> let lam = Translattribute.add_inline_attribute (transl_module Tcoerce_none (field_path rootpath id) modl) - mb_loc mb_attributes + loc mb_attributes in (* Careful: the module value stored in the global may be different from the local module value, in case a coercion is applied. @@ -827,8 +830,8 @@ let transl_store_structure glob map prims str = the compilation unit (add_ident true returns subst unchanged). If not, we can use the value from the global (add_ident true adds id -> Pgetglobal... to subst). *) - Llet(Strict, id, subst_lambda subst lam, - Lsequence(store_ident id, + Llet(Strict, Pgenval, id, subst_lambda subst lam, + Lsequence(store_ident loc id, transl_store rootpath (add_ident true id subst) rem)) | Tstr_recmodule bindings -> let ids = List.map (fun mb -> mb.mb_id) bindings in @@ -838,23 +841,28 @@ let transl_store_structure glob map prims str = (transl_module Tcoerce_none (field_path rootpath id) modl)) bindings - (Lsequence(store_idents ids, + (Lsequence(store_idents Location.none ids, transl_store rootpath (add_idents true ids subst) rem)) | Tstr_class cl_list -> let (ids, class_bindings) = transl_class_bindings cl_list in - let lam = Lletrec(class_bindings, store_idents ids) in + let lam = + Lletrec(class_bindings, store_idents Location.none ids) + in Lsequence(subst_lambda subst lam, transl_store rootpath (add_idents false ids subst) rem) | Tstr_include incl -> let ids = bound_value_identifiers incl.incl_type in let modl = incl.incl_mod in let mid = Ident.create "include" in + let loc = incl.incl_loc in let rec store_idents pos = function [] -> transl_store rootpath (add_idents true ids subst) rem | id :: idl -> - Llet(Alias, id, Lprim(Pfield pos, [Lvar mid]), - Lsequence(store_ident id, store_idents (pos + 1) idl)) in - Llet(Strict, mid, + Llet(Alias, Pgenval, id, Lprim(Pfield pos, [Lvar mid], loc), + Lsequence(store_ident loc id, + store_idents (pos + 1) idl)) + in + Llet(Strict, Pgenval, mid, subst_lambda subst (transl_module Tcoerce_none None modl), store_idents 0 ids) | Tstr_modtype _ @@ -863,24 +871,29 @@ let transl_store_structure glob map prims str = | Tstr_attribute _ -> transl_store rootpath subst rem - and store_ident id = + and store_ident loc id = try let (pos, cc) = Ident.find_same id map in - let init_val = apply_coercion Alias cc (Lvar id) in + let init_val = apply_coercion loc Alias cc (Lvar id) in Lprim(Psetfield(pos, Pointer, Initialization), - [Lprim(Pgetglobal glob, []); init_val]) + [Lprim(Pgetglobal glob, [], loc); init_val], + loc) with Not_found -> fatal_error("Translmod.store_ident: " ^ Ident.unique_name id) - and store_idents idlist = - make_sequence store_ident idlist + and store_idents loc idlist = + make_sequence (store_ident loc) idlist and add_ident may_coerce id subst = try let (pos, cc) = Ident.find_same id map in match cc with Tcoerce_none -> - Ident.add id (Lprim(Pfield pos, [Lprim(Pgetglobal glob, [])])) subst + Ident.add id + (Lprim(Pfield pos, + [Lprim(Pgetglobal glob, [], Location.none)], + Location.none)) + subst | _ -> if may_coerce then subst else assert false with Not_found -> @@ -891,9 +904,10 @@ let transl_store_structure glob map prims str = and store_primitive (pos, prim) cont = Lsequence(Lprim(Psetfield(pos, Pointer, Initialization), - [Lprim(Pgetglobal glob, []); + [Lprim(Pgetglobal glob, [], Location.none); transl_primitive Location.none - prim.pc_desc prim.pc_env prim.pc_type None]), + prim.pc_desc prim.pc_env prim.pc_type None], + Location.none), cont) in List.fold_right store_primitive prims @@ -927,7 +941,7 @@ let build_ident_map restr idlist more_ids = let rec export_map pos map prims undef = function [] -> natural_map pos map prims undef - | (source_pos, Tcoerce_primitive p) :: rem -> + | (_source_pos, Tcoerce_primitive p) :: rem -> export_map (pos + 1) map ((pos, p) :: prims) undef rem | (source_pos, cc) :: rem -> let id = idarray.(source_pos) in @@ -963,10 +977,14 @@ let transl_store_phrases module_name str = let transl_store_implementation module_name (str, restr) = let s = !transl_store_subst in transl_store_subst := Ident.empty; - let (i, r) = transl_store_gen module_name (str, restr) false in + let (i, code) = transl_store_gen module_name (str, restr) false in transl_store_subst := s; { Lambda.main_module_block_size = i; - code = wrap_globals ~flambda:false r; } + code; + (* module_ident is not used by closure, but this allow to share + the type with the flambda version *) + module_ident = Ident.create_persistent module_name; + required_globals = required_globals ~flambda:true code } (* Compile a toplevel phrase *) @@ -988,7 +1006,8 @@ let toploop_getvalue id = Lapply{ap_should_be_tailcall=false; ap_loc=Location.none; ap_func=Lprim(Pfield toploop_getvalue_pos, - [Lprim(Pgetglobal toploop_ident, [])]); + [Lprim(Pgetglobal toploop_ident, [], Location.none)], + Location.none); ap_args=[Lconst(Const_base(Const_string (toplevel_name id, None)))]; ap_inlined=Default_inline; ap_specialised=Default_specialise} @@ -997,7 +1016,8 @@ let toploop_setvalue id lam = Lapply{ap_should_be_tailcall=false; ap_loc=Location.none; ap_func=Lprim(Pfield toploop_setvalue_pos, - [Lprim(Pgetglobal toploop_ident, [])]); + [Lprim(Pgetglobal toploop_ident, [], Location.none)], + Location.none); ap_args=[Lconst(Const_base(Const_string (toplevel_name id, None))); lam]; ap_inlined=Default_inline; @@ -1006,7 +1026,8 @@ let toploop_setvalue id lam = let toploop_setvalue_id id = toploop_setvalue id (Lvar id) let close_toplevel_term (lam, ()) = - IdentSet.fold (fun id l -> Llet(Strict, id, toploop_getvalue id, l)) + IdentSet.fold (fun id l -> Llet(Strict, Pgenval, id, + toploop_getvalue id, l)) (free_variables lam) lam let transl_toplevel_item item = @@ -1062,9 +1083,11 @@ let transl_toplevel_item item = [] -> lambda_unit | id :: ids -> - Lsequence(toploop_setvalue id (Lprim(Pfield pos, [Lvar mid])), + Lsequence(toploop_setvalue id + (Lprim(Pfield pos, [Lvar mid], Location.none)), set_idents (pos + 1) ids) in - Llet(Strict, mid, transl_module Tcoerce_none None modl, set_idents 0 ids) + Llet(Strict, Pgenval, mid, + transl_module Tcoerce_none None modl, set_idents 0 ids) | Tstr_modtype _ | Tstr_open _ | Tstr_primitive _ @@ -1086,9 +1109,9 @@ let transl_toplevel_definition str = let get_component = function None -> Lconst const_unit - | Some id -> Lprim(Pgetglobal id, []) + | Some id -> Lprim(Pgetglobal id, [], Location.none) -let transl_package_flambda component_names target_name coercion = +let transl_package_flambda component_names coercion = let size = match coercion with | Tcoerce_none -> List.length component_names @@ -1098,13 +1121,18 @@ let transl_package_flambda component_names target_name coercion = | Tcoerce_alias _ -> assert false in size, - apply_coercion Strict coercion - (Lprim(Pmakeblock(0, Immutable), List.map get_component component_names)) + apply_coercion Location.none Strict coercion + (Lprim(Pmakeblock(0, Immutable, None), + List.map get_component component_names, + Location.none)) let transl_package component_names target_name coercion = let components = - Lprim(Pmakeblock(0, Immutable), List.map get_component component_names) in - Lprim(Psetglobal target_name, [apply_coercion Strict coercion components]) + Lprim(Pmakeblock(0, Immutable, None), + List.map get_component component_names, Location.none) in + Lprim(Psetglobal target_name, + [apply_coercion Location.none Strict coercion components], + Location.none) (* let components = match coercion with @@ -1132,21 +1160,26 @@ let transl_store_package component_names target_name coercion = make_sequence (fun pos id -> Lprim(Psetfield(pos, Pointer, Initialization), - [Lprim(Pgetglobal target_name, []); - get_component id])) + [Lprim(Pgetglobal target_name, [], Location.none); + get_component id], + Location.none)) 0 component_names) - | Tcoerce_structure (pos_cc_list, id_pos_list) -> + | Tcoerce_structure (pos_cc_list, _id_pos_list) -> let components = - Lprim(Pmakeblock(0, Immutable), List.map get_component component_names) + Lprim(Pmakeblock(0, Immutable, None), + List.map get_component component_names, + Location.none) in let blk = Ident.create "block" in (List.length pos_cc_list, - Llet (Strict, blk, apply_coercion Strict coercion components, + Llet (Strict, Pgenval, blk, + apply_coercion Location.none Strict coercion components, make_sequence - (fun pos id -> + (fun pos _id -> Lprim(Psetfield(pos, Pointer, Initialization), - [Lprim(Pgetglobal target_name, []); - Lprim(Pfield pos, [Lvar blk])])) + [Lprim(Pgetglobal target_name, [], Location.none); + Lprim(Pfield pos, [Lvar blk], Location.none)], + Location.none)) 0 pos_cc_list)) (* (* ignore id_pos_list as the ids are already bound *) diff --git a/bytecomp/translmod.mli b/bytecomp/translmod.mli index 3628a998..f613a2f4 100644 --- a/bytecomp/translmod.mli +++ b/bytecomp/translmod.mli @@ -19,13 +19,14 @@ open Typedtree open Lambda -val transl_implementation: string -> structure * module_coercion -> lambda +val transl_implementation: + string -> structure * module_coercion -> Lambda.program val transl_store_phrases: string -> structure -> int * lambda val transl_store_implementation: string -> structure * module_coercion -> Lambda.program val transl_implementation_flambda: - string -> structure * module_coercion -> (Ident.t * int) * lambda + string -> structure * module_coercion -> Lambda.program val transl_toplevel_definition: structure -> lambda val transl_package: @@ -34,7 +35,7 @@ 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 + Ident.t option list -> 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 1e860502..67f469c0 100644 --- a/bytecomp/translobj.ml +++ b/bytecomp/translobj.ml @@ -33,7 +33,7 @@ let consts : (structured_constant, Ident.t) Hashtbl.t = Hashtbl.create 17 let share c = match c with - Const_block (n, l) when l <> [] -> + Const_block (_n, l) when l <> [] -> begin try Lvar (Hashtbl.find consts c) with Not_found -> @@ -58,9 +58,9 @@ let next_cache tag = (tag, [!method_cache; Lconst(Const_base(Const_int n))]) let rec is_path = function - Lvar _ | Lprim (Pgetglobal _, []) | Lconst _ -> true - | Lprim (Pfield _, [lam]) -> is_path lam - | Lprim ((Parrayrefu _ | Parrayrefs _), [lam1; lam2]) -> + Lvar _ | Lprim (Pgetglobal _, [], _) | Lconst _ -> true + | Lprim (Pfield _, [lam], _) -> is_path lam + | Lprim ((Parrayrefu _ | Parrayrefs _), [lam1; lam2], _) -> is_path lam1 && is_path lam2 | _ -> false @@ -98,12 +98,12 @@ let transl_label_init_general f = let expr, size = f () in let expr = Hashtbl.fold - (fun c id expr -> Llet(Alias, id, Lconst c, expr)) + (fun c id expr -> Llet(Alias, Pgenval, id, Lconst c, expr)) consts expr in (*let expr = List.fold_right - (fun id expr -> Lsequence(Lprim(Pgetglobal id, []), expr)) + (fun id expr -> Lsequence(Lprim(Pgetglobal id, [], Location.none), expr)) (Env.get_required_globals ()) expr in Env.reset_required_globals ();*) @@ -121,8 +121,10 @@ let transl_label_init_flambda f = let expr = if !method_count = 0 then expr else - Llet (Strict, method_cache_id, - Lprim (Pccall prim_makearray, [int !method_count; int 0]), + Llet (Strict, Pgenval, method_cache_id, + Lprim (Pccall prim_makearray, + [int !method_count; int 0], + Location.none), expr) in transl_label_init_general (fun () -> expr, size) @@ -130,15 +132,20 @@ let transl_label_init_flambda f = 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, [])]); + method_cache := Lprim(Pfield size, + [Lprim(Pgetglobal glob, [], Location.none)], + Location.none); let expr = f arg in let (size, expr) = if !method_count = 0 then (size, expr) else (size+1, Lsequence( Lprim(Psetfield(size, Pointer, Initialization), - [Lprim(Pgetglobal glob, []); - Lprim (Pccall prim_makearray, [int !method_count; int 0])]), + [Lprim(Pgetglobal glob, [], Location.none); + Lprim (Pccall prim_makearray, + [int !method_count; int 0], + Location.none)], + Location.none), expr)) in let lam, size = transl_label_init_general (fun () -> (expr, size)) in @@ -176,9 +183,10 @@ let oo_wrap env req f x = let lambda = List.fold_left (fun lambda id -> - Llet(StrictOpt, id, - Lprim(Pmakeblock(0, Mutable), - [lambda_unit; lambda_unit; lambda_unit]), + Llet(StrictOpt, Pgenval, id, + Lprim(Pmakeblock(0, Mutable, None), + [lambda_unit; lambda_unit; lambda_unit], + Location.none), lambda)) lambda !classes in diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml index 60aff406..93b7ec65 100644 --- a/bytecomp/typeopt.ml +++ b/bytecomp/typeopt.ml @@ -20,8 +20,23 @@ open Types open Typedtree open Lambda +let scrape_ty env ty = + let ty = Ctype.expand_head_opt env (Ctype.correct_levels ty) in + match ty.desc with + | Tconstr (p, _, _) -> + begin match Env.find_type p env with + | {type_unboxed = {unboxed = true; _}; _} -> + begin match Typedecl.get_unboxed_type_representation env ty with + | None -> ty + | Some ty2 -> ty2 + end + | _ -> ty + | exception Not_found -> ty + end + | _ -> ty + let scrape env ty = - (Ctype.repr (Ctype.expand_head_opt env (Ctype.correct_levels ty))).desc + (scrape_ty env ty).desc let is_function_type env ty = match scrape env ty with @@ -33,9 +48,6 @@ let is_base_type env ty base_ty_path = | Tconstr(p, _, _) -> Path.same p base_ty_path | _ -> false -let has_base_type exp base_ty_path = - is_base_type exp.exp_env exp.exp_type base_ty_path - let maybe_pointer_type env ty = if Ctype.maybe_pointer_type env ty then Pointer @@ -44,46 +56,57 @@ let maybe_pointer_type env ty = let maybe_pointer exp = maybe_pointer_type exp.exp_env exp.exp_type -let array_element_kind env ty = - match scrape env ty with +type classification = + | Int + | Float + | Lazy + | Addr (* anything except a float or a lazy *) + | Any + +let classify env ty = + let ty = scrape_ty env ty in + if maybe_pointer_type env ty = Immediate then Int + else match ty.desc with | Tvar _ | Tunivar _ -> - Pgenarray - | Tconstr(p, args, abbrev) -> - if Path.same p Predef.path_int || Path.same p Predef.path_char then - Pintarray - else if Path.same p Predef.path_float then - Pfloatarray + Any + | Tconstr (p, _args, _abbrev) -> + if Path.same p Predef.path_float then Float + else if Path.same p Predef.path_lazy_t then Lazy else if Path.same p Predef.path_string + || Path.same p Predef.path_bytes || Path.same p Predef.path_array || Path.same p Predef.path_nativeint || Path.same p Predef.path_int32 - || Path.same p Predef.path_int64 then - Paddrarray + || Path.same p Predef.path_int64 then Addr else begin try - match Env.find_type p env with - {type_kind = Type_abstract} -> - Pgenarray - | {type_kind = Type_variant cstrs} - when List.for_all (fun c -> c.Types.cd_args = Types.Cstr_tuple []) - cstrs -> - Pintarray - | {type_kind = _} -> - Paddrarray + match (Env.find_type p env).type_kind with + | Type_abstract -> + Any + | Type_record _ | Type_variant _ | Type_open -> + Addr with Not_found -> (* This can happen due to e.g. missing -I options, causing some .cmi files to be unavailable. Maybe we should emit a warning. *) - Pgenarray + Any end - | _ -> - Paddrarray + | Tarrow _ | Ttuple _ | Tpackage _ | Tobject _ | Tnil | Tvariant _ -> + Addr + | Tlink _ | Tsubst _ | Tpoly _ | Tfield _ -> + assert false let array_type_kind env ty = match scrape env ty with | Tconstr(p, [elt_ty], _) | Tpoly({desc = Tconstr(p, [elt_ty], _)}, _) when Path.same p Predef.path_array -> - array_element_kind env elt_ty + begin match classify env elt_ty with + | Any -> Pgenarray + | Float -> Pfloatarray + | Addr | Lazy -> Paddrarray + | Int -> Pintarray + end + | _ -> (* This can happen with e.g. Obj.field *) Pgenarray @@ -120,9 +143,32 @@ let layout_table = let bigarray_type_kind_and_layout env typ = match scrape env typ with - | Tconstr(p, [caml_type; elt_type; layout_type], abbrev) -> + | Tconstr(_p, [_caml_type; elt_type; layout_type], _abbrev) -> (bigarray_decode_type env elt_type kind_table Pbigarray_unknown, bigarray_decode_type env layout_type layout_table Pbigarray_unknown_layout) | _ -> (Pbigarray_unknown, Pbigarray_unknown_layout) + +let value_kind env ty = + match scrape env ty with + | Tconstr(p, _, _) when Path.same p Predef.path_int -> + Pintval + | Tconstr(p, _, _) when Path.same p Predef.path_char -> + Pintval + | Tconstr(p, _, _) when Path.same p Predef.path_float -> + Pfloatval + | Tconstr(p, _, _) when Path.same p Predef.path_int32 -> + Pboxedintval Pint32 + | Tconstr(p, _, _) when Path.same p Predef.path_int64 -> + Pboxedintval Pint64 + | Tconstr(p, _, _) when Path.same p Predef.path_nativeint -> + Pboxedintval Pnativeint + | _ -> + Pgenval + + +let lazy_val_requires_forward env ty = + match classify env ty with + | Any | Float | Lazy -> true + | Addr | Int -> false diff --git a/bytecomp/typeopt.mli b/bytecomp/typeopt.mli index d69f09eb..6ac3bbcc 100644 --- a/bytecomp/typeopt.mli +++ b/bytecomp/typeopt.mli @@ -18,7 +18,6 @@ val is_function_type : Env.t -> Types.type_expr -> (Types.type_expr * Types.type_expr) option val is_base_type : Env.t -> Types.type_expr -> Path.t -> bool -val has_base_type : Typedtree.expression -> Path.t -> bool val maybe_pointer_type : Env.t -> Types.type_expr -> Lambda.immediate_or_pointer @@ -29,3 +28,8 @@ val array_kind : Typedtree.expression -> Lambda.array_kind val array_pattern_kind : Typedtree.pattern -> Lambda.array_kind val bigarray_type_kind_and_layout : Env.t -> Types.type_expr -> Lambda.bigarray_kind * Lambda.bigarray_layout +val value_kind : Env.t -> Types.type_expr -> Lambda.value_kind + +val lazy_val_requires_forward : Env.t -> Types.type_expr -> bool + (** Whether a forward block is needed for a lazy thunk on a value, i.e. + if the value can be represented as a float/forward/lazy *) diff --git a/byterun/.depend b/byterun/.depend index c1a4243c..c3f82b66 100644 --- a/byterun/.depend +++ b/byterun/.depend @@ -6,7 +6,8 @@ alloc.o: alloc.c caml/alloc.h caml/compatibility.h caml/misc.h \ array.o: array.c caml/alloc.h caml/compatibility.h caml/misc.h \ caml/config.h caml/../../config/m.h caml/../../config/s.h \ caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ - caml/freelist.h caml/minor_gc.h caml/address_class.h caml/signals.h + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/signals.h \ + spacetime.h backtrace.o: backtrace.c caml/alloc.h caml/compatibility.h caml/misc.h \ caml/config.h caml/../../config/m.h caml/../../config/s.h \ caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h \ @@ -28,7 +29,7 @@ compact.o: compact.c caml/address_class.h caml/config.h \ caml/../../config/m.h caml/../../config/s.h caml/compatibility.h \ caml/misc.h caml/mlvalues.h caml/finalise.h caml/roots.h caml/memory.h \ caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ - caml/gc_ctrl.h caml/weak.h + caml/gc_ctrl.h caml/weak.h caml/compact.h compare.o: compare.c caml/custom.h caml/compatibility.h caml/mlvalues.h \ caml/config.h caml/../../config/m.h caml/../../config/s.h caml/misc.h \ caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ @@ -60,9 +61,9 @@ fail.o: fail.c caml/alloc.h caml/compatibility.h caml/misc.h \ caml/printexc.h caml/signals.h caml/stacks.h finalise.o: finalise.c caml/callback.h caml/compatibility.h \ caml/mlvalues.h caml/config.h caml/../../config/m.h \ - caml/../../config/s.h caml/misc.h caml/fail.h caml/roots.h \ - caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ - caml/minor_gc.h caml/address_class.h caml/signals.h + caml/../../config/s.h caml/misc.h caml/compact.h caml/fail.h \ + caml/finalise.h caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/signals.h fix_code.o: fix_code.c caml/config.h caml/../../config/m.h \ caml/../../config/s.h caml/compatibility.h caml/debugger.h caml/misc.h \ caml/mlvalues.h caml/fix_code.h caml/instruct.h caml/intext.h \ @@ -123,8 +124,8 @@ lexing.o: lexing.c caml/fail.h caml/compatibility.h caml/misc.h \ main.o: main.c caml/misc.h caml/compatibility.h caml/config.h \ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/sys.h major_gc.o: major_gc.c caml/compact.h caml/config.h caml/../../config/m.h \ - caml/../../config/s.h caml/compatibility.h caml/misc.h caml/custom.h \ - caml/mlvalues.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \ + caml/../../config/s.h caml/compatibility.h caml/misc.h caml/mlvalues.h \ + caml/custom.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \ caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ caml/address_class.h caml/gc_ctrl.h caml/signals.h caml/weak.h md5.o: md5.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \ @@ -155,7 +156,8 @@ misc.o: misc.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ obj.o: obj.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ caml/fail.h caml/gc.h caml/interp.h caml/major_gc.h caml/freelist.h \ - caml/memory.h caml/minor_gc.h caml/address_class.h caml/prims.h + caml/memory.h caml/minor_gc.h caml/address_class.h caml/prims.h \ + spacetime.h parsing.o: parsing.c caml/config.h caml/../../config/m.h \ caml/../../config/s.h caml/compatibility.h caml/mlvalues.h caml/misc.h \ caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ @@ -181,6 +183,9 @@ signals_byt.o: signals_byt.c caml/config.h caml/../../config/m.h \ caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \ caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \ caml/signals_machdep.h +spacetime.o: spacetime.c caml/fail.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h stacks.o: stacks.c caml/config.h caml/../../config/m.h \ caml/../../config/s.h caml/compatibility.h caml/fail.h caml/misc.h \ caml/mlvalues.h caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h \ @@ -208,7 +213,7 @@ sys.o: sys.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ caml/debugger.h caml/fail.h caml/gc_ctrl.h caml/instruct.h caml/io.h \ caml/osdeps.h caml/signals.h caml/stacks.h caml/memory.h caml/gc.h \ caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ - caml/sys.h + caml/sys.h caml/version.h terminfo.o: terminfo.c caml/config.h caml/../../config/m.h \ caml/../../config/s.h caml/compatibility.h caml/alloc.h caml/misc.h \ caml/mlvalues.h caml/fail.h caml/io.h @@ -216,7 +221,7 @@ unix.o: unix.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ caml/compatibility.h caml/fail.h caml/misc.h caml/mlvalues.h \ caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \ - caml/sys.h + caml/sys.h caml/io.h weak.o: weak.c caml/alloc.h caml/compatibility.h caml/misc.h \ caml/config.h caml/../../config/m.h caml/../../config/s.h \ caml/mlvalues.h caml/fail.h caml/major_gc.h caml/freelist.h \ @@ -230,7 +235,8 @@ alloc.d.o: alloc.c caml/alloc.h caml/compatibility.h caml/misc.h \ array.d.o: array.c caml/alloc.h caml/compatibility.h caml/misc.h \ caml/config.h caml/../../config/m.h caml/../../config/s.h \ caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ - caml/freelist.h caml/minor_gc.h caml/address_class.h caml/signals.h + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/signals.h \ + spacetime.h backtrace.d.o: backtrace.c caml/alloc.h caml/compatibility.h caml/misc.h \ caml/config.h caml/../../config/m.h caml/../../config/s.h \ caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h \ @@ -252,7 +258,7 @@ compact.d.o: compact.c caml/address_class.h caml/config.h \ caml/../../config/m.h caml/../../config/s.h caml/compatibility.h \ caml/misc.h caml/mlvalues.h caml/finalise.h caml/roots.h caml/memory.h \ caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ - caml/gc_ctrl.h caml/weak.h + caml/gc_ctrl.h caml/weak.h caml/compact.h compare.d.o: compare.c caml/custom.h caml/compatibility.h caml/mlvalues.h \ caml/config.h caml/../../config/m.h caml/../../config/s.h caml/misc.h \ caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ @@ -284,9 +290,9 @@ fail.d.o: fail.c caml/alloc.h caml/compatibility.h caml/misc.h \ caml/printexc.h caml/signals.h caml/stacks.h finalise.d.o: finalise.c caml/callback.h caml/compatibility.h \ caml/mlvalues.h caml/config.h caml/../../config/m.h \ - caml/../../config/s.h caml/misc.h caml/fail.h caml/roots.h \ - caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ - caml/minor_gc.h caml/address_class.h caml/signals.h + caml/../../config/s.h caml/misc.h caml/compact.h caml/fail.h \ + caml/finalise.h caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/signals.h fix_code.d.o: fix_code.c caml/config.h caml/../../config/m.h \ caml/../../config/s.h caml/compatibility.h caml/debugger.h caml/misc.h \ caml/mlvalues.h caml/fix_code.h caml/instruct.h caml/intext.h \ @@ -351,8 +357,8 @@ lexing.d.o: lexing.c caml/fail.h caml/compatibility.h caml/misc.h \ main.d.o: main.c caml/misc.h caml/compatibility.h caml/config.h \ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/sys.h major_gc.d.o: major_gc.c caml/compact.h caml/config.h caml/../../config/m.h \ - caml/../../config/s.h caml/compatibility.h caml/misc.h caml/custom.h \ - caml/mlvalues.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \ + caml/../../config/s.h caml/compatibility.h caml/misc.h caml/mlvalues.h \ + caml/custom.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \ caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ caml/address_class.h caml/gc_ctrl.h caml/signals.h caml/weak.h md5.d.o: md5.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \ @@ -383,7 +389,8 @@ misc.d.o: misc.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ obj.d.o: obj.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ caml/fail.h caml/gc.h caml/interp.h caml/major_gc.h caml/freelist.h \ - caml/memory.h caml/minor_gc.h caml/address_class.h caml/prims.h + caml/memory.h caml/minor_gc.h caml/address_class.h caml/prims.h \ + spacetime.h parsing.d.o: parsing.c caml/config.h caml/../../config/m.h \ caml/../../config/s.h caml/compatibility.h caml/mlvalues.h caml/misc.h \ caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ @@ -409,6 +416,9 @@ signals_byt.d.o: signals_byt.c caml/config.h caml/../../config/m.h \ caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \ caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \ caml/signals_machdep.h +spacetime.d.o: spacetime.c caml/fail.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h stacks.d.o: stacks.c caml/config.h caml/../../config/m.h \ caml/../../config/s.h caml/compatibility.h caml/fail.h caml/misc.h \ caml/mlvalues.h caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h \ @@ -436,7 +446,7 @@ sys.d.o: sys.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ caml/debugger.h caml/fail.h caml/gc_ctrl.h caml/instruct.h caml/io.h \ caml/osdeps.h caml/signals.h caml/stacks.h caml/memory.h caml/gc.h \ caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ - caml/sys.h + caml/sys.h caml/version.h terminfo.d.o: terminfo.c caml/config.h caml/../../config/m.h \ caml/../../config/s.h caml/compatibility.h caml/alloc.h caml/misc.h \ caml/mlvalues.h caml/fail.h caml/io.h @@ -444,7 +454,7 @@ unix.d.o: unix.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ caml/compatibility.h caml/fail.h caml/misc.h caml/mlvalues.h \ caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \ - caml/sys.h + caml/sys.h caml/io.h weak.d.o: weak.c caml/alloc.h caml/compatibility.h caml/misc.h \ caml/config.h caml/../../config/m.h caml/../../config/s.h \ caml/mlvalues.h caml/fail.h caml/major_gc.h caml/freelist.h \ @@ -458,7 +468,8 @@ alloc.i.o: alloc.c caml/alloc.h caml/compatibility.h caml/misc.h \ array.i.o: array.c caml/alloc.h caml/compatibility.h caml/misc.h \ caml/config.h caml/../../config/m.h caml/../../config/s.h \ caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ - caml/freelist.h caml/minor_gc.h caml/address_class.h caml/signals.h + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/signals.h \ + spacetime.h backtrace.i.o: backtrace.c caml/alloc.h caml/compatibility.h caml/misc.h \ caml/config.h caml/../../config/m.h caml/../../config/s.h \ caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h \ @@ -480,7 +491,7 @@ compact.i.o: compact.c caml/address_class.h caml/config.h \ caml/../../config/m.h caml/../../config/s.h caml/compatibility.h \ caml/misc.h caml/mlvalues.h caml/finalise.h caml/roots.h caml/memory.h \ caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ - caml/gc_ctrl.h caml/weak.h + caml/gc_ctrl.h caml/weak.h caml/compact.h compare.i.o: compare.c caml/custom.h caml/compatibility.h caml/mlvalues.h \ caml/config.h caml/../../config/m.h caml/../../config/s.h caml/misc.h \ caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ @@ -512,9 +523,9 @@ fail.i.o: fail.c caml/alloc.h caml/compatibility.h caml/misc.h \ caml/printexc.h caml/signals.h caml/stacks.h finalise.i.o: finalise.c caml/callback.h caml/compatibility.h \ caml/mlvalues.h caml/config.h caml/../../config/m.h \ - caml/../../config/s.h caml/misc.h caml/fail.h caml/roots.h \ - caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ - caml/minor_gc.h caml/address_class.h caml/signals.h + caml/../../config/s.h caml/misc.h caml/compact.h caml/fail.h \ + caml/finalise.h caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/signals.h fix_code.i.o: fix_code.c caml/config.h caml/../../config/m.h \ caml/../../config/s.h caml/compatibility.h caml/debugger.h caml/misc.h \ caml/mlvalues.h caml/fix_code.h caml/instruct.h caml/intext.h \ @@ -575,8 +586,8 @@ lexing.i.o: lexing.c caml/fail.h caml/compatibility.h caml/misc.h \ main.i.o: main.c caml/misc.h caml/compatibility.h caml/config.h \ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/sys.h major_gc.i.o: major_gc.c caml/compact.h caml/config.h caml/../../config/m.h \ - caml/../../config/s.h caml/compatibility.h caml/misc.h caml/custom.h \ - caml/mlvalues.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \ + caml/../../config/s.h caml/compatibility.h caml/misc.h caml/mlvalues.h \ + caml/custom.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \ caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ caml/address_class.h caml/gc_ctrl.h caml/signals.h caml/weak.h md5.i.o: md5.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \ @@ -607,7 +618,8 @@ misc.i.o: misc.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ obj.i.o: obj.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ caml/fail.h caml/gc.h caml/interp.h caml/major_gc.h caml/freelist.h \ - caml/memory.h caml/minor_gc.h caml/address_class.h caml/prims.h + caml/memory.h caml/minor_gc.h caml/address_class.h caml/prims.h \ + spacetime.h parsing.i.o: parsing.c caml/config.h caml/../../config/m.h \ caml/../../config/s.h caml/compatibility.h caml/mlvalues.h caml/misc.h \ caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ @@ -633,6 +645,9 @@ signals_byt.i.o: signals_byt.c caml/config.h caml/../../config/m.h \ caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \ caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \ caml/signals_machdep.h +spacetime.i.o: spacetime.c caml/fail.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h stacks.i.o: stacks.c caml/config.h caml/../../config/m.h \ caml/../../config/s.h caml/compatibility.h caml/fail.h caml/misc.h \ caml/mlvalues.h caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h \ @@ -660,7 +675,7 @@ sys.i.o: sys.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ caml/debugger.h caml/fail.h caml/gc_ctrl.h caml/instruct.h caml/io.h \ caml/osdeps.h caml/signals.h caml/stacks.h caml/memory.h caml/gc.h \ caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ - caml/sys.h + caml/sys.h caml/version.h terminfo.i.o: terminfo.c caml/config.h caml/../../config/m.h \ caml/../../config/s.h caml/compatibility.h caml/alloc.h caml/misc.h \ caml/mlvalues.h caml/fail.h caml/io.h @@ -668,7 +683,7 @@ unix.i.o: unix.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ caml/compatibility.h caml/fail.h caml/misc.h caml/mlvalues.h \ caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \ - caml/sys.h + caml/sys.h caml/io.h weak.i.o: weak.c caml/alloc.h caml/compatibility.h caml/misc.h \ caml/config.h caml/../../config/m.h caml/../../config/s.h \ caml/mlvalues.h caml/fail.h caml/major_gc.h caml/freelist.h \ @@ -682,7 +697,8 @@ alloc.pic.o: alloc.c caml/alloc.h caml/compatibility.h caml/misc.h \ array.pic.o: array.c caml/alloc.h caml/compatibility.h caml/misc.h \ caml/config.h caml/../../config/m.h caml/../../config/s.h \ caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ - caml/freelist.h caml/minor_gc.h caml/address_class.h caml/signals.h + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/signals.h \ + spacetime.h backtrace.pic.o: backtrace.c caml/alloc.h caml/compatibility.h caml/misc.h \ caml/config.h caml/../../config/m.h caml/../../config/s.h \ caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h \ @@ -704,7 +720,7 @@ compact.pic.o: compact.c caml/address_class.h caml/config.h \ caml/../../config/m.h caml/../../config/s.h caml/compatibility.h \ caml/misc.h caml/mlvalues.h caml/finalise.h caml/roots.h caml/memory.h \ caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ - caml/gc_ctrl.h caml/weak.h + caml/gc_ctrl.h caml/weak.h caml/compact.h compare.pic.o: compare.c caml/custom.h caml/compatibility.h caml/mlvalues.h \ caml/config.h caml/../../config/m.h caml/../../config/s.h caml/misc.h \ caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ @@ -736,9 +752,9 @@ fail.pic.o: fail.c caml/alloc.h caml/compatibility.h caml/misc.h \ caml/printexc.h caml/signals.h caml/stacks.h finalise.pic.o: finalise.c caml/callback.h caml/compatibility.h \ caml/mlvalues.h caml/config.h caml/../../config/m.h \ - caml/../../config/s.h caml/misc.h caml/fail.h caml/roots.h \ - caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ - caml/minor_gc.h caml/address_class.h caml/signals.h + caml/../../config/s.h caml/misc.h caml/compact.h caml/fail.h \ + caml/finalise.h caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/signals.h fix_code.pic.o: fix_code.c caml/config.h caml/../../config/m.h \ caml/../../config/s.h caml/compatibility.h caml/debugger.h caml/misc.h \ caml/mlvalues.h caml/fix_code.h caml/instruct.h caml/intext.h \ @@ -799,8 +815,8 @@ lexing.pic.o: lexing.c caml/fail.h caml/compatibility.h caml/misc.h \ main.pic.o: main.c caml/misc.h caml/compatibility.h caml/config.h \ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/sys.h major_gc.pic.o: major_gc.c caml/compact.h caml/config.h caml/../../config/m.h \ - caml/../../config/s.h caml/compatibility.h caml/misc.h caml/custom.h \ - caml/mlvalues.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \ + caml/../../config/s.h caml/compatibility.h caml/misc.h caml/mlvalues.h \ + caml/custom.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \ caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ caml/address_class.h caml/gc_ctrl.h caml/signals.h caml/weak.h md5.pic.o: md5.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \ @@ -831,7 +847,8 @@ misc.pic.o: misc.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ obj.pic.o: obj.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \ caml/fail.h caml/gc.h caml/interp.h caml/major_gc.h caml/freelist.h \ - caml/memory.h caml/minor_gc.h caml/address_class.h caml/prims.h + caml/memory.h caml/minor_gc.h caml/address_class.h caml/prims.h \ + spacetime.h parsing.pic.o: parsing.c caml/config.h caml/../../config/m.h \ caml/../../config/s.h caml/compatibility.h caml/mlvalues.h caml/misc.h \ caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ @@ -857,6 +874,9 @@ signals_byt.pic.o: signals_byt.c caml/config.h caml/../../config/m.h \ caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \ caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \ caml/signals_machdep.h +spacetime.pic.o: spacetime.c caml/fail.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h stacks.pic.o: stacks.c caml/config.h caml/../../config/m.h \ caml/../../config/s.h caml/compatibility.h caml/fail.h caml/misc.h \ caml/mlvalues.h caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h \ @@ -884,7 +904,7 @@ sys.pic.o: sys.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ caml/debugger.h caml/fail.h caml/gc_ctrl.h caml/instruct.h caml/io.h \ caml/osdeps.h caml/signals.h caml/stacks.h caml/memory.h caml/gc.h \ caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ - caml/sys.h + caml/sys.h caml/version.h terminfo.pic.o: terminfo.c caml/config.h caml/../../config/m.h \ caml/../../config/s.h caml/compatibility.h caml/alloc.h caml/misc.h \ caml/mlvalues.h caml/fail.h caml/io.h @@ -892,7 +912,7 @@ unix.pic.o: unix.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ caml/compatibility.h caml/fail.h caml/misc.h caml/mlvalues.h \ caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \ - caml/sys.h + caml/sys.h caml/io.h weak.pic.o: weak.c caml/alloc.h caml/compatibility.h caml/misc.h \ caml/config.h caml/../../config/m.h caml/../../config/s.h \ caml/mlvalues.h caml/fail.h caml/major_gc.h caml/freelist.h \ diff --git a/byterun/Makefile.common b/byterun/Makefile.common index 5bcd6779..144d3a3e 100644 --- a/byterun/Makefile.common +++ b/byterun/Makefile.common @@ -26,22 +26,15 @@ COMMONOBJS=\ compare.o ints.o floats.o str.o array.o io.o extern.o intern.o \ hash.o sys.o meta.o parsing.o gc_ctrl.o terminfo.o md5.o obj.o \ lexing.o callback.o debugger.o weak.o compact.o finalise.o custom.o \ - dynlink.o + dynlink.o spacetime.o PRIMS=\ alloc.c array.c compare.c extern.c floats.c gc_ctrl.c hash.c \ intern.c interp.c ints.c io.c lexing.c md5.c meta.c obj.c parsing.c \ signals.c str.c sys.c terminfo.c callback.c weak.c finalise.c stacks.c \ - dynlink.c backtrace_prim.c backtrace.c + dynlink.c backtrace_prim.c backtrace.c spacetime.c -PUBLIC_INCLUDES=\ - address_class.h alloc.h callback.h config.h custom.h fail.h gc.h \ - hash.h intext.h \ - memory.h misc.h mlvalues.h printexc.h signals.h compatibility.h \ - version.h - - -all:: ocamlrun$(EXE) ld.conf libcamlrun.$(A) all-$(RUNTIMED) +all:: ocamlrun$(EXE) ld.conf libcamlrun.$(A) all-$(RUNTIMED) primitives .PHONY: all all-noruntimed: @@ -70,9 +63,9 @@ install:: cd "$(INSTALL_LIBDIR)"; $(RANLIB) libcamlrun.$(A) if test -d "$(INSTALL_LIBDIR)/caml"; then : ; \ else mkdir "$(INSTALL_LIBDIR)/caml"; fi - for i in $(PUBLIC_INCLUDES); do \ - sed -f ../tools/cleanup-header caml/$$i \ - > "$(INSTALL_LIBDIR)/caml/$$i"; \ + for i in caml/*.h; do \ + sed -f ../tools/cleanup-header $$i \ + > "$(INSTALL_LIBDIR)/$$i"; \ done cp ld.conf "$(INSTALL_LIBDIR)/ld.conf" .PHONY: install @@ -116,7 +109,8 @@ primitives : $(PRIMS) | sort | uniq > primitives prims.c : primitives - (echo '#include "caml/mlvalues.h"'; \ + (echo '#define CAML_INTERNALS'; \ + echo '#include "caml/mlvalues.h"'; \ echo '#include "caml/prims.h"'; \ sed -e 's/.*/extern value &();/' primitives; \ echo 'c_primitive caml_builtin_cprim[] = {'; \ diff --git a/byterun/Makefile.nt b/byterun/Makefile.nt index 06b39c69..e74bdd9c 100644 --- a/byterun/Makefile.nt +++ b/byterun/Makefile.nt @@ -16,6 +16,7 @@ include Makefile.common CFLAGS=-DOCAML_STDLIB_DIR='"$(LIBDIR)"' $(IFLEXDIR) +DFLAGS=$(CFLAGS) -DDEBUG ifdef BOOTSTRAPPING_FLEXLINK MAKE_OCAMLRUN=$(MKEXE_BOOT) @@ -33,7 +34,7 @@ ocamlrun$(EXE): libcamlrun.$(A) prims.$(O) $(call SYSLIB,ws2_32) $(EXTRALIBS)) ocamlrund$(EXE): libcamlrund.$(A) prims.$(O) main.$(O) - $(MKEXE) -o ocamlrund$(EXE) $(BYTECCDBGCOMPOPTS) prims.$(O) \ + $(MKEXE) -o ocamlrund$(EXE) prims.$(O) \ $(call SYSLIB,ws2_32) $(EXTRALIBS) libcamlrund.$(A) libcamlrun.$(A): $(OBJS) @@ -45,8 +46,9 @@ libcamlrund.$(A): $(DOBJS) %.$(O): %.c $(CC) $(CFLAGS) $(BYTECCCOMPOPTS) -c $< +# It is imperative that there is no space after $(NAME_OBJ_FLAG) %.$(DBGO): %.c - $(CC) $(CFLAGS) $(BYTECCDBGCOMPOPTS) -c -o $@ $< + $(CC) $(DFLAGS) $(BYTECCDBGCOMPOPTS) -c $(NAME_OBJ_FLAG)$@ $< .depend.nt: .depend rm -f .depend.win32 @@ -59,7 +61,10 @@ libcamlrund.$(A): $(DOBJS) echo " caml/freelist.h caml/minor_gc.h caml/osdeps.h caml/signals.h"\ >> .depend.win32 cat .depend >> .depend.win32 - sed -e '/\.d\.o/q' -e 's/^\(.*\)\.o:/\1.$$(O) \1.$$(DBGO):/' \ + sed -ne '/\.pic\.o/q' \ + -e 's/^\(.*\)\.d\.o:/\1.$$(DBGO):/' \ + -e 's/^\(.*\)\.o:/\1.$$(O):/' \ + -e p \ .depend.win32 > .depend.nt rm -f .depend.win32 diff --git a/byterun/alloc.c b/byterun/alloc.c index 54b83608..7bda3921 100644 --- a/byterun/alloc.c +++ b/byterun/alloc.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* 1. Allocation functions doing the same work as the macros in the case where [Setup_for_gc] and [Restore_after_gc] are no-ops. 2. Convenience functions related to allocation. @@ -64,6 +66,23 @@ CAMLexport value caml_alloc_small (mlsize_t wosize, tag_t tag) return result; } +CAMLexport value caml_alloc_small_with_my_or_given_profinfo (mlsize_t wosize, + tag_t tag, uintnat profinfo) +{ + if (profinfo == 0) { + return caml_alloc_small(wosize, tag); + } + else { + value result; + + Assert (wosize > 0); + Assert (wosize <= Max_young_wosize); + Assert (tag < 256); + Alloc_small_with_profinfo (result, wosize, tag, profinfo); + return result; + } +} + /* [n] is a number of words (fields) */ CAMLexport value caml_alloc_tuple(mlsize_t n) { @@ -134,6 +153,23 @@ CAMLexport value caml_alloc_array(value (*funct)(char const *), } } +/* [len] is a number of floats */ +CAMLprim value caml_alloc_float_array(mlsize_t len) +{ + mlsize_t wosize = len * Double_wosize; + value result; + if (wosize == 0) + return Atom(0); + else if (wosize <= Max_young_wosize){ + Alloc_small (result, wosize, Double_array_tag); + }else { + result = caml_alloc_shr (wosize, Double_array_tag); + result = caml_check_urgent_gc (result); + } + return result; +} + + CAMLexport value caml_copy_string_array(char const ** arr) { return caml_alloc_array(caml_copy_string, arr); diff --git a/byterun/array.c b/byterun/array.c index ccfe2488..900182db 100644 --- a/byterun/array.c +++ b/byterun/array.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Operations on arrays */ #include #include "caml/alloc.h" @@ -21,6 +23,9 @@ #include "caml/misc.h" #include "caml/mlvalues.h" #include "caml/signals.h" +#include "spacetime.h" + +static const mlsize_t mlsize_t_max = -1; /* returns number of elements (either fields or floats) */ CAMLexport mlsize_t caml_array_length(value array) @@ -161,6 +166,7 @@ CAMLprim value caml_make_float_vect(value len) } /* [len] is a [value] representing number of words or floats */ +/* Spacetime profiling assumes that this function is only called from OCaml. */ CAMLprim value caml_make_vect(value len, value init) { CAMLparam2 (len, init); @@ -185,7 +191,9 @@ CAMLprim value caml_make_vect(value len, value init) } else { if (size > Max_wosize) caml_invalid_argument("Array.make"); if (size <= Max_young_wosize) { - res = caml_alloc_small(size, 0); + uintnat profinfo; + Get_my_profinfo_with_cached_backtrace(profinfo, size); + res = caml_alloc_small_with_my_or_given_profinfo(size, 0, profinfo); for (i = 0; i < size; i++) Field(res, i) = init; } else if (Is_block(init) && Is_young(init)) { @@ -307,6 +315,7 @@ static value caml_array_gather(intnat num_arrays, size = 0; isfloat = 0; for (i = 0; i < num_arrays; i++) { + if (mlsize_t_max - lengths[i] < size) caml_invalid_argument("Array.concat"); size += lengths[i]; if (Tag_val(arrays[i]) == Double_array_tag) isfloat = 1; } @@ -316,8 +325,8 @@ static value caml_array_gather(intnat num_arrays, } else if (isfloat) { /* This is an array of floats. We can use memcpy directly. */ + if (size > Max_wosize/Double_wosize) caml_invalid_argument("Array.concat"); wsize = size * Double_wosize; - if (wsize > Max_wosize) caml_invalid_argument("Array.concat"); res = caml_alloc(wsize, Double_array_tag); for (i = 0, pos = 0; i < num_arrays; i++) { memcpy((double *)res + pos, diff --git a/byterun/backtrace.c b/byterun/backtrace.c index 12435722..a5bc7809 100644 --- a/byterun/backtrace.c +++ b/byterun/backtrace.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Stack backtrace for uncaught exceptions */ #include @@ -28,8 +30,8 @@ /* The table of debug information fragments */ struct ext_table caml_debug_info; -CAMLexport int caml_backtrace_active = 0; -CAMLexport int caml_backtrace_pos = 0; +CAMLexport int32_t caml_backtrace_active = 0; +CAMLexport int32_t caml_backtrace_pos = 0; CAMLexport backtrace_slot * caml_backtrace_buffer = NULL; CAMLexport value caml_backtrace_last_exn = Val_unit; @@ -64,13 +66,14 @@ CAMLprim value caml_backtrace_status(value vunit) note that the test for compiler-inserted raises is slightly redundant: (!li->loc_valid && li->loc_is_raise) - caml_extract_location_info above guarantees that when li->loc_valid is + caml_debuginfo_location guarantees that when li->loc_valid is 0, then li->loc_is_raise is always 1, so the latter test is useless. We kept it to keep code identical to the byterun/ implementation. */ static void print_location(struct caml_loc_info * li, int index) { char * info; + char * inlined; /* Ignore compiler-inserted raise */ if (!li->loc_valid && li->loc_is_raise) return; @@ -87,11 +90,16 @@ static void print_location(struct caml_loc_info * li, int index) else info = "Called from"; } + if (li->loc_is_inlined) { + inlined = " (inlined)"; + } else { + inlined = ""; + } if (! li->loc_valid) { - fprintf(stderr, "%s unknown location\n", info); + fprintf(stderr, "%s unknown location%s\n", info, inlined); } else { - fprintf (stderr, "%s file \"%s\", line %d, characters %d-%d\n", - info, li->loc_filename, li->loc_lnum, + fprintf (stderr, "%s file \"%s\"%s, line %d, characters %d-%d\n", + info, li->loc_filename, inlined, li->loc_lnum, li->loc_startchr, li->loc_endchr); } } @@ -101,6 +109,7 @@ CAMLexport void caml_print_exception_backtrace(void) { int i; struct caml_loc_info li; + debuginfo dbg; if (!caml_debug_info_available()) { fprintf(stderr, "(Cannot print stack backtrace: " @@ -109,8 +118,13 @@ CAMLexport void caml_print_exception_backtrace(void) } for (i = 0; i < caml_backtrace_pos; i++) { - caml_extract_location_info(caml_backtrace_buffer[i], &li); - print_location(&li, i); + for (dbg = caml_debuginfo_extract(caml_backtrace_buffer[i]); + dbg != NULL; + dbg = caml_debuginfo_next(dbg)) + { + caml_debuginfo_location(dbg, &li); + print_location(&li, i); + } } } @@ -146,34 +160,34 @@ CAMLprim value caml_get_exception_raw_backtrace(value unit) res = caml_alloc(saved_caml_backtrace_pos, 0); for (i = 0; i < saved_caml_backtrace_pos; i++) { - Field(res, i) = - caml_val_raw_backtrace_slot(saved_caml_backtrace_buffer[i]); + Field(res, i) = Val_backtrace_slot(saved_caml_backtrace_buffer[i]); } } CAMLreturn(res); } +#define Val_debuginfo(bslot) (Val_long((uintnat)(bslot)>>1)) +#define Debuginfo_val(vslot) ((debuginfo)(Long_val(vslot) << 1)) + /* Convert the raw backtrace to a data structure usable from OCaml */ -CAMLprim value caml_convert_raw_backtrace_slot(value backtrace_slot) +static value caml_convert_debuginfo(debuginfo dbg) { - CAMLparam1(backtrace_slot); + CAMLparam0(); CAMLlocal2(p, fname); struct caml_loc_info li; - if (!caml_debug_info_available()) - caml_failwith("No debug information available"); - - caml_extract_location_info(caml_raw_backtrace_slot_val(backtrace_slot), &li); + caml_debuginfo_location(dbg, &li); if (li.loc_valid) { fname = caml_copy_string(li.loc_filename); - p = caml_alloc_small(5, 0); + p = caml_alloc_small(6, 0); Field(p, 0) = Val_bool(li.loc_is_raise); Field(p, 1) = fname; Field(p, 2) = Val_int(li.loc_lnum); Field(p, 3) = Val_int(li.loc_startchr); Field(p, 4) = Val_int(li.loc_endchr); + Field(p, 5) = Val_bool(li.loc_is_inlined); } else { p = caml_alloc_small(1, 1); Field(p, 0) = Val_bool(li.loc_is_raise); @@ -182,6 +196,89 @@ CAMLprim value caml_convert_raw_backtrace_slot(value backtrace_slot) CAMLreturn(p); } +CAMLprim value caml_convert_raw_backtrace_slot(value slot) +{ + if (!caml_debug_info_available()) + caml_failwith("No debug information available"); + + return (caml_convert_debuginfo(Debuginfo_val(slot))); +} + +/* Convert the raw backtrace to a data structure usable from OCaml */ +CAMLprim value caml_convert_raw_backtrace(value bt) +{ + CAMLparam1(bt); + CAMLlocal1(array); + intnat i, index; + + if (!caml_debug_info_available()) + caml_failwith("No debug information available"); + + for (i = 0, index = 0; i < Wosize_val(bt); ++i) + { + debuginfo dbg; + for (dbg = caml_debuginfo_extract(Backtrace_slot_val(Field(bt, i))); + dbg != NULL; + dbg = caml_debuginfo_next(dbg)) + index++; + } + + array = caml_alloc(index, 0); + + for (i = 0, index = 0; i < Wosize_val(bt); ++i) + { + debuginfo dbg; + for (dbg = caml_debuginfo_extract(Backtrace_slot_val(Field(bt, i))); + dbg != NULL; + dbg = caml_debuginfo_next(dbg)) + { + Store_field(array, index, caml_convert_debuginfo(dbg)); + index++; + } + } + + CAMLreturn(array); +} + +CAMLprim value caml_raw_backtrace_length(value bt) +{ + return Val_int(Wosize_val(bt)); +} + +CAMLprim value caml_raw_backtrace_slot(value bt, value index) +{ + uintnat i; + debuginfo dbg; + + i = Long_val(index); + if (i >= Wosize_val(bt)) + caml_invalid_argument("Printexc.get_raw_backtrace_slot: " + "index out of bounds"); + dbg = caml_debuginfo_extract(Backtrace_slot_val(Field(bt, i))); + return Val_debuginfo(dbg); +} + +CAMLprim value caml_raw_backtrace_next_slot(value slot) +{ + debuginfo dbg; + + CAMLparam1(slot); + CAMLlocal1(v); + + dbg = Debuginfo_val(slot); + dbg = caml_debuginfo_next(dbg); + + if (dbg == NULL) + v = Val_int(0); /* None */ + else + { + v = caml_alloc(1, 0); + Field(v, 0) = Val_debuginfo(dbg); + } + + CAMLreturn(v); +} + /* the function below is deprecated: we previously returned directly the OCaml-usable representation, instead of the raw backtrace as an abstract type, but this has a large performance overhead if you @@ -197,13 +294,15 @@ CAMLprim value caml_get_exception_backtrace(value unit) intnat i; if (!caml_debug_info_available()) { - res = Val_int(0); /* None */ + res = Val_int(0); /* None */ } else { backtrace = caml_get_exception_raw_backtrace(Val_unit); arr = caml_alloc(Wosize_val(backtrace), 0); for (i = 0; i < Wosize_val(backtrace); i++) { - Store_field(arr, i, caml_convert_raw_backtrace_slot(Field(backtrace, i))); + backtrace_slot slot = Backtrace_slot_val(Field(backtrace, i)); + debuginfo dbg = caml_debuginfo_extract(slot); + Store_field(arr, i, caml_convert_debuginfo(dbg)); } res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */ diff --git a/byterun/backtrace_prim.c b/byterun/backtrace_prim.c index 081c97fa..c81955a4 100644 --- a/byterun/backtrace_prim.c +++ b/byterun/backtrace_prim.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Stack backtrace for uncaught exceptions */ #include @@ -247,24 +249,6 @@ void caml_stash_backtrace(value exn, code_t pc, value * sp, int reraise) } } -/* In order to prevent the GC from walking through the debug - information (which have no headers), we transform code pointers to - 31/63 bits ocaml integers by shifting them by 1 to the right. We do - not lose information as code pointers are aligned. - - In particular, we do not need to use [caml_modify] when setting - an array element with such a value. -*/ -value caml_val_raw_backtrace_slot(backtrace_slot pc) -{ - return Val_long ((uintnat)pc >> 1); -} - -backtrace_slot caml_raw_backtrace_slot_val(value v) -{ - return ((backtrace_slot)(Long_val(v) << 1)); -} - /* returns the next frame pointer (or NULL if none is available); updates *sp to point to the following one, and *trsp to the next trap frame, which we will skip when we reach it */ @@ -323,7 +307,7 @@ CAMLprim value caml_get_current_callstack(value max_frames_value) for (trace_pos = 0; trace_pos < trace_size; trace_pos++) { code_t p = caml_next_frame_pointer(&sp, &trsp); Assert(p != NULL); - Store_field(trace, trace_pos, caml_val_raw_backtrace_slot(p)); + Field(trace, trace_pos) = Val_backtrace_slot(p); } } @@ -436,10 +420,10 @@ static struct ev_info *event_for_location(code_t pc) /* Extract location information for the given PC */ -void caml_extract_location_info(backtrace_slot slot, - /*out*/ struct caml_loc_info * li) +void caml_debuginfo_location(debuginfo dbg, + /*out*/ struct caml_loc_info * li) { - code_t pc = slot; + code_t pc = dbg; struct ev_info *event = event_for_location(pc); li->loc_is_raise = caml_is_instruction(*pc, RAISE) || @@ -449,8 +433,20 @@ void caml_extract_location_info(backtrace_slot slot, return; } li->loc_valid = 1; + li->loc_is_inlined = 0; li->loc_filename = event->ev_filename; li->loc_lnum = event->ev_lnum; li->loc_startchr = event->ev_startchr; li->loc_endchr = event->ev_endchr; } + +debuginfo caml_debuginfo_extract(backtrace_slot slot) +{ + return (debuginfo)slot; +} + +debuginfo caml_debuginfo_next(debuginfo dbg) +{ + /* No inlining in bytecode */ + return NULL; +} diff --git a/byterun/callback.c b/byterun/callback.c index 7697edcc..bef4b3df 100644 --- a/byterun/callback.c +++ b/byterun/callback.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Callbacks from C to OCaml */ #include diff --git a/byterun/caml/alloc.h b/byterun/caml/alloc.h index 64a250d7..5bd3d7ce 100644 --- a/byterun/caml/alloc.h +++ b/byterun/caml/alloc.h @@ -30,6 +30,7 @@ extern "C" { CAMLextern value caml_alloc (mlsize_t wosize, tag_t); CAMLextern value caml_alloc_small (mlsize_t wosize, tag_t); CAMLextern value caml_alloc_tuple (mlsize_t wosize); +CAMLextern value caml_alloc_float_array (mlsize_t len); CAMLextern value caml_alloc_string (mlsize_t len); /* len in bytes (chars) */ CAMLextern value caml_copy_string (char const *); CAMLextern value caml_copy_string_array (char const **); @@ -41,6 +42,11 @@ CAMLextern value caml_alloc_array (value (*funct) (char const *), char const ** array); CAMLextern value caml_alloc_sprintf(const char * format, ...); +CAMLextern value caml_alloc_with_profinfo (mlsize_t, tag_t, intnat); +CAMLextern value caml_alloc_small_with_my_or_given_profinfo ( + mlsize_t, tag_t, uintnat); +CAMLextern value caml_alloc_small_with_profinfo (mlsize_t, tag_t, intnat); + typedef void (*final_fun)(value); CAMLextern value caml_alloc_final (mlsize_t wosize, final_fun, /*finalization function*/ @@ -49,6 +55,21 @@ CAMLextern value caml_alloc_final (mlsize_t wosize, CAMLextern int caml_convert_flag_list (value, int *); +/* Convenience functions to deal with unboxable types. */ +static inline value caml_alloc_unboxed (value arg) { return arg; } +static inline value caml_alloc_boxed (value arg) { + value result = caml_alloc_small (1, 0); + Field (result, 0) = arg; + return result; +} +static inline value caml_field_unboxed (value arg) { return arg; } +static inline value caml_field_boxed (value arg) { return Field (arg, 0); } + +/* Unannotated unboxable types are boxed by default. (may change in the + future) */ +#define caml_alloc_unboxable caml_alloc_boxed +#define caml_field_unboxable caml_field_boxed + #ifdef __cplusplus } #endif diff --git a/byterun/caml/backtrace.h b/byterun/caml/backtrace.h index a1630f2b..e9acf33c 100644 --- a/byterun/caml/backtrace.h +++ b/byterun/caml/backtrace.h @@ -16,6 +16,8 @@ #ifndef CAML_BACKTRACE_H #define CAML_BACKTRACE_H +#ifdef CAML_INTERNALS + #include "mlvalues.h" #include "exec.h" @@ -129,4 +131,6 @@ CAMLextern void caml_print_exception_backtrace(void); void caml_init_backtrace(void); CAMLexport void caml_init_debug_info(void); +#endif /* CAML_INTERNALS */ + #endif /* CAML_BACKTRACE_H */ diff --git a/byterun/caml/backtrace_prim.h b/byterun/caml/backtrace_prim.h index c59dbc33..025242d0 100644 --- a/byterun/caml/backtrace_prim.h +++ b/byterun/caml/backtrace_prim.h @@ -16,6 +16,8 @@ #ifndef CAML_BACKTRACE_PRIM_H #define CAML_BACKTRACE_PRIM_H +#ifdef CAML_INTERNALS + #include "backtrace.h" /* Backtrace generation is split in [backtrace.c] and [backtrace_prim.c]. @@ -36,22 +38,37 @@ struct caml_loc_info { int loc_lnum; int loc_startchr; int loc_endchr; + int loc_is_inlined; }; +/* When compiling with -g, backtrace slots have debug info associated. + * When a call is inlined in native mode, debuginfos form a linked list. + */ +typedef void * debuginfo; + /* Check availability of debug information before extracting a trace. * Relevant for bytecode, always true for native code. */ int caml_debug_info_available(void); +/* Return debuginfo associated to a slot or NULL. */ +debuginfo caml_debuginfo_extract(backtrace_slot slot); + +/* In case of an inlined call return next debuginfo or NULL otherwise. */ +debuginfo caml_debuginfo_next(debuginfo dbg); + /* Extract locations from backtrace_slot */ -void caml_extract_location_info(backtrace_slot pc, - /*out*/ struct caml_loc_info * li); +void caml_debuginfo_location(debuginfo dbg, /*out*/ struct caml_loc_info * li); + +/* In order to prevent the GC from walking through the debug + information (which have no headers), we transform slots to 31/63 bits + ocaml integers by shifting them by 1 to the right. We do not lose + information as slots are aligned. -/* Expose a [backtrace_slot] as a OCaml value of type [raw_backtrace_slot]. - * The value returned should be an immediate and not an OCaml block, so that it - * is safe to store using direct assignment and [Field], and not [Store_field] / - * [caml_modify]. */ -value caml_val_raw_backtrace_slot(backtrace_slot pc); -backtrace_slot caml_raw_backtrace_slot_val(value slot); + In particular, we do not need to use [caml_modify] when setting + an array element with such a value. + */ +#define Val_backtrace_slot(bslot) (Val_long(((uintnat)(bslot))>>1)) +#define Backtrace_slot_val(vslot) ((backtrace_slot)(Long_val(vslot) << 1)) #define BACKTRACE_BUFFER_SIZE 1024 @@ -66,4 +83,6 @@ backtrace_slot caml_raw_backtrace_slot_val(value slot); * explicitly. */ +#endif /* CAML_INTERNALS */ + #endif /* CAML_BACKTRACE_PRIM_H */ diff --git a/byterun/caml/compact.h b/byterun/caml/compact.h index 72950583..4f98fb12 100644 --- a/byterun/caml/compact.h +++ b/byterun/caml/compact.h @@ -16,12 +16,16 @@ #ifndef CAML_COMPACT_H #define CAML_COMPACT_H +#ifdef CAML_INTERNALS #include "config.h" #include "misc.h" +#include "mlvalues.h" -extern void caml_compact_heap (void); -extern void caml_compact_heap_maybe (void); +void caml_compact_heap (void); +void caml_compact_heap_maybe (void); +void invert_root (value v, value *p); +#endif /* CAML_INTERNALS */ #endif /* CAML_COMPACT_H */ diff --git a/byterun/caml/compare.h b/byterun/caml/compare.h index d6456f46..54b71581 100644 --- a/byterun/caml/compare.h +++ b/byterun/caml/compare.h @@ -16,6 +16,10 @@ #ifndef CAML_COMPARE_H #define CAML_COMPARE_H +#ifdef CAML_INTERNALS + CAMLextern int caml_compare_unordered; +#endif /* CAML_INTERNALS */ + #endif /* CAML_COMPARE_H */ diff --git a/byterun/caml/custom.h b/byterun/caml/custom.h index a3119d0f..6bc3aa95 100644 --- a/byterun/caml/custom.h +++ b/byterun/caml/custom.h @@ -58,13 +58,13 @@ CAMLextern void caml_register_custom_operations(struct custom_operations * ops); CAMLextern int caml_compare_unordered; /* Used by custom comparison to report unordered NaN-like cases. */ -/* */ +#ifdef CAML_INTERNALS extern struct custom_operations * caml_find_custom_operations(char * ident); extern struct custom_operations * caml_final_custom_operations(void (*fn)(value)); extern void caml_init_custom_operations(void); -/* */ +#endif /* CAML_INTERNALS */ #ifdef __cplusplus } diff --git a/byterun/caml/debugger.h b/byterun/caml/debugger.h index 00a97749..c98f35a8 100644 --- a/byterun/caml/debugger.h +++ b/byterun/caml/debugger.h @@ -18,6 +18,8 @@ #ifndef CAML_DEBUGGER_H #define CAML_DEBUGGER_H +#ifdef CAML_INTERNALS + #include "misc.h" #include "mlvalues.h" @@ -110,4 +112,6 @@ enum debugger_reply { /* Program exited due to a stray exception. */ }; +#endif /* CAML_INTERNALS */ + #endif /* CAML_DEBUGGER_H */ diff --git a/byterun/caml/dynlink.h b/byterun/caml/dynlink.h index 3c5b9b73..0eed7e7f 100644 --- a/byterun/caml/dynlink.h +++ b/byterun/caml/dynlink.h @@ -18,6 +18,8 @@ #ifndef CAML_DYNLINK_H #define CAML_DYNLINK_H +#ifdef CAML_INTERNALS + #include "misc.h" /* Build the table of primitives, given a search path, a list @@ -35,4 +37,6 @@ extern struct ext_table caml_shared_libs_path; Used for executables generated by ocamlc -output-obj. */ extern void caml_build_primitive_table_builtin(void); +#endif /* CAML_INTERNALS */ + #endif /* CAML_DYNLINK_H */ diff --git a/byterun/caml/exec.h b/byterun/caml/exec.h index eee7596d..f39747ac 100644 --- a/byterun/caml/exec.h +++ b/byterun/caml/exec.h @@ -18,6 +18,8 @@ #ifndef CAML_EXEC_H #define CAML_EXEC_H +#ifdef CAML_INTERNALS + /* Executable bytecode files are composed of a number of sections, identified by 4-character names. A table of contents at the end of the file lists the section names along with their sizes, @@ -58,5 +60,6 @@ struct exec_trailer { #define EXEC_MAGIC "Caml1999X011" +#endif /* CAML_INTERNALS */ #endif /* CAML_EXEC_H */ diff --git a/byterun/caml/fail.h b/byterun/caml/fail.h index aa417b75..07cb37d1 100644 --- a/byterun/caml/fail.h +++ b/byterun/caml/fail.h @@ -16,9 +16,9 @@ #ifndef CAML_FAIL_H #define CAML_FAIL_H -/* */ +#ifdef CAML_INTERNALS #include -/* */ +#endif /* CAML_INTERNALS */ #ifndef CAML_NAME_SPACE #include "compatibility.h" @@ -26,7 +26,7 @@ #include "misc.h" #include "mlvalues.h" -/* */ +#ifdef CAML_INTERNALS #define OUT_OF_MEMORY_EXN 0 /* "Out_of_memory" */ #define SYS_ERROR_EXN 1 /* "Sys_error" */ #define FAILURE_EXN 2 /* "Failure" */ @@ -56,7 +56,7 @@ CAMLextern struct longjmp_buffer * caml_external_raise; extern value caml_exn_bucket; int caml_is_special_exception(value exn); -/* */ +#endif /* CAML_INTERNALS */ #ifdef __cplusplus extern "C" { diff --git a/byterun/caml/finalise.h b/byterun/caml/finalise.h index 9fbac826..5315ac21 100644 --- a/byterun/caml/finalise.h +++ b/byterun/caml/finalise.h @@ -16,14 +16,21 @@ #ifndef CAML_FINALISE_H #define CAML_FINALISE_H +#ifdef CAML_INTERNALS + #include "roots.h" -void caml_final_update (void); +void caml_final_update_mark_phase (void); +void caml_final_update_clean_phase (void); void caml_final_do_calls (void); -void caml_final_do_strong_roots (scanning_action f); -void caml_final_do_weak_roots (scanning_action f); -void caml_final_do_young_roots (scanning_action f); +void caml_final_do_roots (scanning_action f); +void caml_final_invert_finalisable_values (); +void caml_final_oldify_young_roots (); void caml_final_empty_young (void); +void caml_final_update_minor_roots(void); value caml_final_register (value f, value v); +void caml_final_invariant_check(void); + +#endif /* CAML_INTERNALS */ #endif /* CAML_FINALISE_H */ diff --git a/byterun/caml/fix_code.h b/byterun/caml/fix_code.h index 9c39d481..7e5633d6 100644 --- a/byterun/caml/fix_code.h +++ b/byterun/caml/fix_code.h @@ -18,6 +18,7 @@ #ifndef CAML_FIX_CODE_H #define CAML_FIX_CODE_H +#ifdef CAML_INTERNALS #include "config.h" #include "misc.h" @@ -39,4 +40,6 @@ extern char * caml_instr_base; void caml_thread_code (code_t code, asize_t len); #endif +#endif /* CAML_INTERNALS */ + #endif /* CAML_FIX_CODE_H */ diff --git a/byterun/caml/freelist.h b/byterun/caml/freelist.h index f6c812ee..54e0e822 100644 --- a/byterun/caml/freelist.h +++ b/byterun/caml/freelist.h @@ -18,6 +18,7 @@ #ifndef CAML_FREELIST_H #define CAML_FREELIST_H +#ifdef CAML_INTERNALS #include "misc.h" #include "mlvalues.h" @@ -32,5 +33,6 @@ void caml_fl_add_blocks (value); void caml_make_free_blocks (value *, mlsize_t wsz, int, int); void caml_set_allocation_policy (uintnat); +#endif /* CAML_INTERNALS */ #endif /* CAML_FREELIST_H */ diff --git a/byterun/caml/gc.h b/byterun/caml/gc.h index a57a2bc2..776ddc77 100644 --- a/byterun/caml/gc.h +++ b/byterun/caml/gc.h @@ -46,6 +46,23 @@ + (tag_t) (tag))) \ ) +#ifdef WITH_SPACETIME +struct ext_table; +extern uintnat caml_spacetime_my_profinfo(struct ext_table**, uintnat); +#define Make_header_with_profinfo(wosize, tag, color, profinfo) \ + (Make_header(wosize, tag, color) \ + | ((((intnat) profinfo) & PROFINFO_MASK) << PROFINFO_SHIFT) \ + ) +#define Make_header_allocated_here(wosize, tag, color) \ + (Make_header_with_profinfo(wosize, tag, color, \ + caml_spacetime_my_profinfo(NULL, wosize)) \ + ) +#else +#define Make_header_allocated_here Make_header +#define Make_header_with_profinfo(wosize, tag, color, profinfo) \ + Make_header(wosize | (profinfo & (intnat) 0), tag, color) +#endif + #define Is_white_val(val) (Color_val(val) == Caml_white) #define Is_gray_val(val) (Color_val(val) == Caml_gray) #define Is_blue_val(val) (Color_val(val) == Caml_blue) diff --git a/byterun/caml/gc_ctrl.h b/byterun/caml/gc_ctrl.h index 924a1091..ebf1a40b 100644 --- a/byterun/caml/gc_ctrl.h +++ b/byterun/caml/gc_ctrl.h @@ -16,6 +16,8 @@ #ifndef CAML_GC_CTRL_H #define CAML_GC_CTRL_H +#ifdef CAML_INTERNALS + #include "misc.h" extern double @@ -45,8 +47,12 @@ void caml_init_gc (uintnat minor_size, uintnat major_size, uintnat major_incr, uintnat percent_fr, uintnat percent_m, uintnat window); +CAMLextern value caml_gc_stat(value v); + #ifdef DEBUG void caml_heap_check (void); #endif +#endif /* CAML_INTERNALS */ + #endif /* CAML_GC_CTRL_H */ diff --git a/byterun/caml/globroots.h b/byterun/caml/globroots.h index b580e6de..10fe66f5 100644 --- a/byterun/caml/globroots.h +++ b/byterun/caml/globroots.h @@ -18,10 +18,14 @@ #ifndef CAML_GLOBROOTS_H #define CAML_GLOBROOTS_H +#ifdef CAML_INTERNALS + #include "mlvalues.h" #include "roots.h" void caml_scan_global_roots(scanning_action f); void caml_scan_global_young_roots(scanning_action f); +#endif /* CAML_INTERNALS */ + #endif /* CAML_GLOBROOTS_H */ diff --git a/byterun/caml/hooks.h b/byterun/caml/hooks.h new file mode 100644 index 00000000..c9814263 --- /dev/null +++ b/byterun/caml/hooks.h @@ -0,0 +1,42 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Fabrice Le Fessant, INRIA de Paris */ +/* */ +/* Copyright 2016 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#ifndef CAML_HOOKS_H +#define CAML_HOOKS_H + +#include "misc.h" +#include "memory.h" + +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef CAML_INTERNALS + +#ifdef NATIVE_CODE + +/* executed just before calling the entry point of a dynamically + loaded native code module. */ +CAMLextern void (*caml_natdynlink_hook)(void* handle, char* unit); + +#endif /* NATIVE_CODE */ + +#endif /* CAML_INTERNALS */ + +#ifdef __cplusplus +} +#endif + +#endif /* CAML_HOOKS_H */ diff --git a/byterun/caml/instrtrace.h b/byterun/caml/instrtrace.h index 9ff363fb..2e42a80a 100644 --- a/byterun/caml/instrtrace.h +++ b/byterun/caml/instrtrace.h @@ -18,6 +18,7 @@ #ifndef _instrtrace_ #define _instrtrace_ +#ifdef CAML_INTERNALS #include "mlvalues.h" #include "misc.h" @@ -28,4 +29,7 @@ void caml_disasm_instr (code_t pc); void caml_trace_value_file (value v, code_t prog, int proglen, FILE * f); void caml_trace_accu_sp_file(value accu, value * sp, code_t prog, int proglen, FILE * f); + +#endif /* CAML_INTERNALS */ + #endif diff --git a/byterun/caml/instruct.h b/byterun/caml/instruct.h index 94816bca..73798333 100644 --- a/byterun/caml/instruct.h +++ b/byterun/caml/instruct.h @@ -18,6 +18,8 @@ #ifndef CAML_INSTRUCT_H #define CAML_INSTRUCT_H +#ifdef CAML_INTERNALS + enum instructions { ACC0, ACC1, ACC2, ACC3, ACC4, ACC5, ACC6, ACC7, ACC, PUSH, @@ -60,5 +62,6 @@ enum instructions { RERAISE, RAISE_NOTRACE, FIRST_UNIMPLEMENTED_OP}; +#endif /* CAML_INTERNALS */ #endif /* CAML_INSTRUCT_H */ diff --git a/byterun/caml/int64_emul.h b/byterun/caml/int64_emul.h index 970bfe49..c1cddcc0 100644 --- a/byterun/caml/int64_emul.h +++ b/byterun/caml/int64_emul.h @@ -19,6 +19,8 @@ #ifndef CAML_INT64_EMUL_H #define CAML_INT64_EMUL_H +#ifdef CAML_INTERNALS + #include #ifdef ARCH_BIG_ENDIAN @@ -286,4 +288,6 @@ static int64_t I64_bswap(int64_t x) return res; } +#endif /* CAML_INTERNALS */ + #endif /* CAML_INT64_EMUL_H */ diff --git a/byterun/caml/int64_format.h b/byterun/caml/int64_format.h index e1570e37..40250ed9 100644 --- a/byterun/caml/int64_format.h +++ b/byterun/caml/int64_format.h @@ -19,6 +19,8 @@ #ifndef CAML_INT64_FORMAT_H #define CAML_INT64_FORMAT_H +#ifdef CAML_INTERNALS + static void I64_format(char * buffer, char * fmt, int64_t x) { static char conv_lower[] = "0123456789abcdef"; @@ -104,4 +106,6 @@ static void I64_format(char * buffer, char * fmt, int64_t x) *p = 0; } +#endif /* CAML_INTERNALS */ + #endif /* CAML_INT64_FORMAT_H */ diff --git a/byterun/caml/int64_native.h b/byterun/caml/int64_native.h index 269811c5..7df66511 100644 --- a/byterun/caml/int64_native.h +++ b/byterun/caml/int64_native.h @@ -20,6 +20,8 @@ #ifndef CAML_INT64_NATIVE_H #define CAML_INT64_NATIVE_H +#ifdef CAML_INTERNALS + #define I64_literal(hi,lo) ((int64_t)(hi) << 32 | (lo)) #define I64_split(x,hi,lo) (hi = (uint32_t)((x)>>32), lo = (uint32_t)(x)) #define I64_compare(x,y) (((x) > (y)) - ((x) < (y))) @@ -60,4 +62,6 @@ (((x) & 0x00FF000000000000ULL) >> 40) | \ (((x) & 0xFF00000000000000ULL) >> 56)) +#endif /* CAML_INTERNALS */ + #endif /* CAML_INT64_NATIVE_H */ diff --git a/byterun/caml/interp.h b/byterun/caml/interp.h index 120c2d95..d1ebdc01 100644 --- a/byterun/caml/interp.h +++ b/byterun/caml/interp.h @@ -18,6 +18,8 @@ #ifndef CAML_INTERP_H #define CAML_INTERP_H +#ifdef CAML_INTERNALS + #include "misc.h" #include "mlvalues.h" @@ -30,4 +32,6 @@ void caml_prepare_bytecode(code_t prog, asize_t prog_size); /* tell the runtime that a bytecode program is no more needed */ void caml_release_bytecode(code_t prog, asize_t prog_size); +#endif /* CAML_INTERNALS */ + #endif /* CAML_INTERP_H */ diff --git a/byterun/caml/intext.h b/byterun/caml/intext.h index 3deaf3a0..673c6fc0 100644 --- a/byterun/caml/intext.h +++ b/byterun/caml/intext.h @@ -24,7 +24,7 @@ #include "misc.h" #include "mlvalues.h" -/* */ +#ifdef CAML_INTERNALS #include "io.h" /* Magic number */ @@ -103,7 +103,7 @@ void caml_output_val (struct channel * chan, value v, value flags); /* Output [v] with flags [flags] on the channel [chan]. */ -/* */ +#endif /* CAML_INTERNALS */ #ifdef __cplusplus extern "C" { @@ -122,10 +122,21 @@ CAMLextern intnat caml_output_value_to_block(value v, value flags, in bytes. Return the number of bytes actually written in buffer. Raise [Failure] if buffer is too short. */ -/* */ +#ifdef CAML_INTERNALS value caml_input_val (struct channel * chan); /* Read a structured value from the channel [chan]. */ -/* */ + +extern value caml_input_value_to_outside_heap (value channel); + /* As for [caml_input_value], but the value is unmarshalled into + malloc blocks that are not added to the heap. Not for the + casual user. */ + +extern int caml_extern_allow_out_of_heap; + /* Permit the marshaller to traverse structures that look like OCaml + values but do not live in the OCaml heap. */ + +extern value caml_output_value(value vchan, value v, value flags); +#endif /* CAML_INTERNALS */ CAMLextern value caml_input_val_from_string (value str, intnat ofs); /* Read a structured value from the OCaml string [str], starting @@ -172,7 +183,7 @@ CAMLextern void caml_deserialize_block_8(void * data, intnat len); CAMLextern void caml_deserialize_block_float_8(void * data, intnat len); CAMLextern void caml_deserialize_error(char * msg); -/* */ +#ifdef CAML_INTERNALS /* Auxiliary stuff for sending code pointers */ @@ -183,9 +194,11 @@ struct code_fragment { char digest_computed; }; +CAMLextern struct code_fragment * caml_extern_find_code(char *addr); + struct ext_table caml_code_fragments_table; -/* */ +#endif /* CAML_INTERNALS */ #ifdef __cplusplus } diff --git a/byterun/caml/io.h b/byterun/caml/io.h index e17b3e9a..f388bd9f 100644 --- a/byterun/caml/io.h +++ b/byterun/caml/io.h @@ -18,6 +18,8 @@ #ifndef CAML_IO_H #define CAML_IO_H +#ifdef CAML_INTERNALS + #include "misc.h" #include "mlvalues.h" @@ -51,7 +53,10 @@ struct channel { }; enum { - CHANNEL_FLAG_FROM_SOCKET = 1 /* For Windows */ + CHANNEL_FLAG_FROM_SOCKET = 1, /* For Windows */ +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) + CHANNEL_FLAG_BLOCKING_WRITE = 2, +#endif }; /* For an output channel: @@ -63,12 +68,12 @@ enum { /* Functions and macros that can be called from C. Take arguments of type struct channel *. No locking is performed. */ -#define putch(channel, ch) do{ \ +#define caml_putch(channel, ch) do{ \ if ((channel)->curr >= (channel)->end) caml_flush_partial(channel); \ *((channel)->curr)++ = (ch); \ }while(0) -#define getch(channel) \ +#define caml_getch(channel) \ ((channel)->curr >= (channel)->max \ ? caml_refill(channel) \ : (unsigned char) *((channel)->curr)++) @@ -88,7 +93,7 @@ CAMLextern void caml_really_putblock (struct channel *, char *, intnat); CAMLextern unsigned char caml_refill (struct channel *); CAMLextern uint32_t caml_getword (struct channel *); CAMLextern int caml_getblock (struct channel *, char *, intnat); -CAMLextern int caml_really_getblock (struct channel *, char *, intnat); +CAMLextern intnat caml_really_getblock (struct channel *, char *, intnat); /* Extract a struct channel * from the heap object representing it */ @@ -115,4 +120,6 @@ CAMLextern struct channel * caml_all_opened_channels; #define Val_file_offset(fofs) caml_copy_int64(fofs) #define File_offset_val(v) ((file_offset) Int64_val(v)) +#endif /* CAML_INTERNALS */ + #endif /* CAML_IO_H */ diff --git a/byterun/caml/major_gc.h b/byterun/caml/major_gc.h index 15d46e48..98909c0a 100644 --- a/byterun/caml/major_gc.h +++ b/byterun/caml/major_gc.h @@ -16,6 +16,7 @@ #ifndef CAML_MAJOR_GC_H #define CAML_MAJOR_GC_H +#ifdef CAML_INTERNALS #include "freelist.h" #include "misc.h" @@ -68,6 +69,10 @@ int caml_major_ring_index; double caml_major_work_credit; extern double caml_gc_clock; +/* [caml_major_gc_hook] is called just between the end of the mark + phase and the beginning of the sweep phase of the major GC */ +CAMLextern void (*caml_major_gc_hook)(void); + void caml_init_major_heap (asize_t); /* size in bytes */ asize_t caml_clip_heap_chunk_wsz (asize_t wsz); void caml_darken (value, value *); @@ -76,5 +81,6 @@ void major_collection (void); void caml_finish_major_cycle (void); void caml_set_major_window (int); +#endif /* CAML_INTERNALS */ #endif /* CAML_MAJOR_GC_H */ diff --git a/byterun/caml/md5.h b/byterun/caml/md5.h index f88fa8bf..e83c16cd 100644 --- a/byterun/caml/md5.h +++ b/byterun/caml/md5.h @@ -18,6 +18,7 @@ #ifndef CAML_MD5_H #define CAML_MD5_H +#ifdef CAML_INTERNALS #include "mlvalues.h" #include "io.h" @@ -27,6 +28,8 @@ CAMLextern value caml_md5_chan (value vchan, value len); CAMLextern void caml_md5_block(unsigned char digest[16], void * data, uintnat len); +CAMLextern value caml_md5_channel(struct channel *chan, intnat toread); + struct MD5Context { uint32_t buf[4]; uint32_t bits[2]; @@ -39,5 +42,6 @@ CAMLextern void caml_MD5Update (struct MD5Context *context, unsigned char *buf, CAMLextern void caml_MD5Final (unsigned char *digest, struct MD5Context *ctx); CAMLextern void caml_MD5Transform (uint32_t *buf, uint32_t *in); +#endif /* CAML_INTERNALS */ #endif /* CAML_MD5_H */ diff --git a/byterun/caml/memory.h b/byterun/caml/memory.h index 9a1287c6..608b702a 100644 --- a/byterun/caml/memory.h +++ b/byterun/caml/memory.h @@ -22,11 +22,11 @@ #include "compatibility.h" #endif #include "config.h" -/* */ +#ifdef CAML_INTERNALS #include "gc.h" #include "major_gc.h" #include "minor_gc.h" -/* */ +#endif /* CAML_INTERNALS */ #include "misc.h" #include "mlvalues.h" @@ -36,6 +36,16 @@ extern "C" { CAMLextern value caml_alloc_shr (mlsize_t wosize, tag_t); +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) +CAMLextern value caml_alloc_shr_with_profinfo (mlsize_t, tag_t, intnat); +CAMLextern value caml_alloc_shr_preserving_profinfo (mlsize_t, tag_t, + header_t); +#else +#define caml_alloc_shr_with_profinfo(size, tag, profinfo) \ + caml_alloc_shr(size, tag) +#define caml_alloc_shr_preserving_profinfo(size, tag, header) \ + caml_alloc_shr(size, tag) +#endif CAMLextern value caml_alloc_shr_no_raise (mlsize_t wosize, tag_t); CAMLextern void caml_adjust_gc_speed (mlsize_t, mlsize_t); CAMLextern void caml_alloc_dependent_memory (mlsize_t bsz); @@ -49,6 +59,7 @@ CAMLextern void * caml_stat_resize (void *, asize_t); /* Size in bytes. */ CAMLextern int caml_init_alloc_for_heap (void); CAMLextern char *caml_alloc_for_heap (asize_t request); /* Size in bytes. */ CAMLextern void caml_free_for_heap (char *mem); +CAMLextern void caml_disown_for_heap (char *mem); CAMLextern int caml_add_to_heap (char *mem); CAMLextern color_t caml_allocation_color (void *hp); @@ -56,7 +67,7 @@ CAMLextern int caml_huge_fallback_count; /* void caml_shrink_heap (char *); Only used in compact.c */ -/* */ +#ifdef CAML_INTERNALS extern uintnat caml_use_huge_pages; @@ -83,7 +94,8 @@ int caml_page_table_initialize(mlsize_t bytesize); #define DEBUG_clear(result, wosize) #endif -#define Alloc_small(result, wosize, tag) do{ CAMLassert ((wosize) >= 1); \ +#define Alloc_small_with_profinfo(result, wosize, tag, profinfo) do { \ + CAMLassert ((wosize) >= 1); \ CAMLassert ((tag_t) (tag) < 256); \ CAMLassert ((wosize) <= Max_young_wosize); \ caml_young_ptr -= Whsize_wosize (wosize); \ @@ -95,16 +107,27 @@ int caml_page_table_initialize(mlsize_t bytesize); Restore_after_gc; \ caml_young_ptr -= Whsize_wosize (wosize); \ } \ - Hd_hp (caml_young_ptr) = Make_header ((wosize), (tag), Caml_black); \ + Hd_hp (caml_young_ptr) = \ + Make_header_with_profinfo ((wosize), (tag), Caml_black, profinfo); \ (result) = Val_hp (caml_young_ptr); \ DEBUG_clear ((result), (wosize)); \ }while(0) +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) +extern uintnat caml_spacetime_my_profinfo(struct ext_table**, uintnat); +#define Alloc_small(result, wosize, tag) \ + Alloc_small_with_profinfo(result, wosize, tag, \ + caml_spacetime_my_profinfo(NULL, wosize)) +#else +#define Alloc_small(result, wosize, tag) \ + Alloc_small_with_profinfo(result, wosize, tag, (uintnat) 0) +#endif + /* Deprecated alias for [caml_modify] */ #define Modify(fp,val) caml_modify((fp), (val)) -/* */ +#endif /* CAML_INTERNALS */ struct caml__roots_block { struct caml__roots_block *next; @@ -198,6 +221,7 @@ CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */ #define CAMLxparam1(x) \ struct caml__roots_block caml__roots_##x; \ CAMLunused_start int caml__dummy_##x = ( \ + (void) caml__frame, \ (caml__roots_##x.next = caml_local_roots), \ (caml_local_roots = &caml__roots_##x), \ (caml__roots_##x.nitems = 1), \ @@ -209,6 +233,7 @@ CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */ #define CAMLxparam2(x, y) \ struct caml__roots_block caml__roots_##x; \ CAMLunused_start int caml__dummy_##x = ( \ + (void) caml__frame, \ (caml__roots_##x.next = caml_local_roots), \ (caml_local_roots = &caml__roots_##x), \ (caml__roots_##x.nitems = 1), \ @@ -221,6 +246,7 @@ CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */ #define CAMLxparam3(x, y, z) \ struct caml__roots_block caml__roots_##x; \ CAMLunused_start int caml__dummy_##x = ( \ + (void) caml__frame, \ (caml__roots_##x.next = caml_local_roots), \ (caml_local_roots = &caml__roots_##x), \ (caml__roots_##x.nitems = 1), \ @@ -234,6 +260,7 @@ CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */ #define CAMLxparam4(x, y, z, t) \ struct caml__roots_block caml__roots_##x; \ CAMLunused_start int caml__dummy_##x = ( \ + (void) caml__frame, \ (caml__roots_##x.next = caml_local_roots), \ (caml_local_roots = &caml__roots_##x), \ (caml__roots_##x.nitems = 1), \ @@ -248,6 +275,7 @@ CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */ #define CAMLxparam5(x, y, z, t, u) \ struct caml__roots_block caml__roots_##x; \ CAMLunused_start int caml__dummy_##x = ( \ + (void) caml__frame, \ (caml__roots_##x.next = caml_local_roots), \ (caml_local_roots = &caml__roots_##x), \ (caml__roots_##x.nitems = 1), \ @@ -263,6 +291,7 @@ CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */ #define CAMLxparamN(x, size) \ struct caml__roots_block caml__roots_##x; \ CAMLunused_start int caml__dummy_##x = ( \ + (void) caml__frame, \ (caml__roots_##x.next = caml_local_roots), \ (caml_local_roots = &caml__roots_##x), \ (caml__roots_##x.nitems = (size)), \ diff --git a/byterun/caml/misc.h b/byterun/caml/misc.h index ce3ce161..be7d00d4 100644 --- a/byterun/caml/misc.h +++ b/byterun/caml/misc.h @@ -36,9 +36,9 @@ typedef size_t asize_t; #define NULL 0 #endif -/* */ +#ifdef CAML_INTERNALS typedef char * addr; -/* */ +#endif /* CAML_INTERNALS */ /* Noreturn is preserved for compatibility reasons. Instead of the legacy GCC/Clang-only @@ -124,7 +124,101 @@ CAMLnoreturn_end; CAMLextern char * caml_strdup(const char * s); CAMLextern char * caml_strconcat(int n, ...); /* n args of const char * type */ -/* */ +/* Use macros for some system calls being called from OCaml itself. + These calls can be either traced for security reasons, or changed to + virtualize the program. */ + + +#ifndef CAML_WITH_CPLUGINS + +#define CAML_SYS_EXIT(retcode) exit(retcode) +#define CAML_SYS_OPEN(filename,flags,perm) open(filename,flags,perm) +#define CAML_SYS_CLOSE(fd) close(fd) +#define CAML_SYS_STAT(filename,st) stat(filename,st) +#define CAML_SYS_UNLINK(filename) unlink(filename) +#define CAML_SYS_RENAME(old_name,new_name) rename(old_name, new_name) +#define CAML_SYS_CHDIR(dirname) chdir(dirname) +#define CAML_SYS_GETENV(varname) getenv(varname) +#define CAML_SYS_SYSTEM(command) system(command) +#define CAML_SYS_READ_DIRECTORY(dirname,tbl) caml_read_directory(dirname,tbl) + +#else + + +#define CAML_CPLUGINS_EXIT 0 +#define CAML_CPLUGINS_OPEN 1 +#define CAML_CPLUGINS_CLOSE 2 +#define CAML_CPLUGINS_STAT 3 +#define CAML_CPLUGINS_UNLINK 4 +#define CAML_CPLUGINS_RENAME 5 +#define CAML_CPLUGINS_CHDIR 6 +#define CAML_CPLUGINS_GETENV 7 +#define CAML_CPLUGINS_SYSTEM 8 +#define CAML_CPLUGINS_READ_DIRECTORY 9 +#define CAML_CPLUGINS_PRIMS_MAX 9 + +#define CAML_CPLUGINS_PRIMS_BITMAP ((1 << CAML_CPLUGINS_PRIMS_MAX)-1) + +extern intnat (*caml_cplugins_prim)(int,intnat,intnat,intnat); + +#define CAML_SYS_PRIM_1(code,prim,arg1) \ + (caml_cplugins_prim == NULL) ? prim(arg1) : \ + caml_cplugins_prim(code,(intnat) (arg1),0,0) +#define CAML_SYS_STRING_PRIM_1(code,prim,arg1) \ + (caml_cplugins_prim == NULL) ? prim(arg1) : \ + (char*)caml_cplugins_prim(code,(intnat) (arg1),0,0) +#define CAML_SYS_PRIM_2(code,prim,arg1,arg2) \ + (caml_cplugins_prim == NULL) ? prim(arg1,arg2) : \ + caml_cplugins_prim(code,(intnat) (arg1), (intnat) (arg2),0) +#define CAML_SYS_PRIM_3(code,prim,arg1,arg2,arg3) \ + (caml_cplugins_prim == NULL) ? prim(arg1,arg2,arg3) : \ + caml_cplugins_prim(code,(intnat) (arg1), (intnat) (arg2),(intnat) (arg3)) + +#define CAML_SYS_EXIT(retcode) \ + CAML_SYS_PRIM_1(CAML_CPLUGINS_EXIT,exit,retcode) +#define CAML_SYS_OPEN(filename,flags,perm) \ + CAML_SYS_PRIM_3(CAML_CPLUGINS_OPEN,open,filename,flags,perm) +#define CAML_SYS_CLOSE(fd) \ + CAML_SYS_PRIM_1(CAML_CPLUGINS_CLOSE,close,fd) +#define CAML_SYS_STAT(filename,st) \ + CAML_SYS_PRIM_2(CAML_CPLUGINS_STAT,stat,filename,st) +#define CAML_SYS_UNLINK(filename) \ + CAML_SYS_PRIM_1(CAML_CPLUGINS_UNLINK,unlink,filename) +#define CAML_SYS_RENAME(old_name,new_name) \ + CAML_SYS_PRIM_2(CAML_CPLUGINS_RENAME,rename,old_name,new_name) +#define CAML_SYS_CHDIR(dirname) \ + CAML_SYS_PRIM_1(CAML_CPLUGINS_CHDIR,chdir,dirname) +#define CAML_SYS_GETENV(varname) \ + CAML_SYS_STRING_PRIM_1(CAML_CPLUGINS_GETENV,getenv,varname) +#define CAML_SYS_SYSTEM(command) \ + CAML_SYS_PRIM_1(CAML_CPLUGINS_SYSTEM,system,command) +#define CAML_SYS_READ_DIRECTORY(dirname,tbl) \ + CAML_SYS_PRIM_2(CAML_CPLUGINS_READ_DIRECTORY,caml_read_directory, \ + dirname,tbl) + +#define CAML_CPLUGIN_CONTEXT_API 0 + +struct cplugin_context { + int api_version; + int prims_bitmap; + char *exe_name; + char** argv; + char *plugin; /* absolute filename of plugin, do a copy if you need it ! */ + char *ocaml_version; +/* end of CAML_CPLUGIN_CONTEXT_API version 0 */ +}; + +extern void caml_cplugins_init(char * exe_name, char **argv); + +/* A plugin MUST define a symbol "caml_cplugin_init" with the prototype: + +void caml_cplugin_init(struct cplugin_context *ctx) +*/ + +/* to write plugins for CAML_SYS_READ_DIRECTORY, we will need the + definition of struct ext_table to be public. */ + +#endif /* CAML_WITH_CPLUGINS */ /* Data structures */ @@ -138,6 +232,12 @@ extern void caml_ext_table_init(struct ext_table * tbl, int init_capa); extern int caml_ext_table_add(struct ext_table * tbl, void * data); extern void caml_ext_table_remove(struct ext_table * tbl, void * data); extern void caml_ext_table_free(struct ext_table * tbl, int free_entries); +extern void caml_ext_table_clear(struct ext_table * tbl, int free_entries); + +CAMLextern int caml_read_directory(char * dirname, struct ext_table * contents); + + +#ifdef CAML_INTERNALS /* GC flags and messages */ @@ -301,7 +401,7 @@ extern void CAML_INSTR_ATEXIT (void); #endif /* CAML_INSTR */ -/* */ +#endif /* CAML_INTERNALS */ #ifdef __cplusplus } diff --git a/byterun/caml/mlvalues.h b/byterun/caml/mlvalues.h index 05791433..c4d31b99 100644 --- a/byterun/caml/mlvalues.h +++ b/byterun/caml/mlvalues.h @@ -94,10 +94,33 @@ For 64-bit architectures: +--------+-------+-----+ bits 63 10 9 8 7 0 +For x86-64 with Spacetime profiling: + P = PROFINFO_WIDTH (as set by "configure", currently 26 bits, giving a + maximum block size of just under 4Gb) + +----------------+----------------+-------------+ + | profiling info | wosize | color | tag | + +----------------+----------------+-------------+ +bits 63 (64-P) (63-P) 10 9 8 7 0 + */ +#define PROFINFO_SHIFT (64 - PROFINFO_WIDTH) +#define PROFINFO_MASK ((1ull << PROFINFO_WIDTH) - 1ull) + #define Tag_hd(hd) ((tag_t) ((hd) & 0xFF)) +#ifdef WITH_SPACETIME +#define Hd_no_profinfo(hd) ((hd) & ~(PROFINFO_MASK << PROFINFO_SHIFT)) +#define Wosize_hd(hd) ((mlsize_t) ((Hd_no_profinfo(hd)) >> 10)) +#else #define Wosize_hd(hd) ((mlsize_t) ((hd) >> 10)) +#endif /* SPACETIME */ +#ifdef ARCH_SIXTYFOUR +/* [Profinfo_hd] is used when the compiler is not configured for Spacetime + (e.g. when decoding profiles). */ +#define Profinfo_hd(hd) (((mlsize_t) ((hd) >> PROFINFO_SHIFT)) & PROFINFO_MASK) +#else +#define Profinfo_hd(hd) ((hd) & 0) +#endif /* ARCH_SIXTYFOUR */ #define Hd_val(val) (((header_t *) (val)) [-1]) /* Also an l-value. */ #define Hd_op(op) (Hd_val (op)) /* Also an l-value. */ @@ -113,7 +136,11 @@ bits 63 10 9 8 7 0 #define Num_tags (1 << 8) #ifdef ARCH_SIXTYFOUR +#ifdef WITH_SPACETIME +#define Max_wosize (((intnat)1 << (54-PROFINFO_WIDTH)) - 1) +#else #define Max_wosize (((intnat)1 << 54) - 1) +#endif #else #define Max_wosize ((1 << 22) - 1) #endif @@ -140,6 +167,8 @@ bits 63 10 9 8 7 0 #define Bhsize_hp(hp) (Bsize_wsize (Whsize_hp (hp))) #define Bhsize_hd(hd) (Bsize_wsize (Whsize_hd (hd))) +#define Profinfo_val(val) (Profinfo_hd (Hd_val (val))) + #ifdef ARCH_BIG_ENDIAN #define Tag_val(val) (((unsigned char *) (val)) [-1]) /* Also an l-value. */ diff --git a/byterun/caml/osdeps.h b/byterun/caml/osdeps.h index 71c2197e..7fcf903a 100644 --- a/byterun/caml/osdeps.h +++ b/byterun/caml/osdeps.h @@ -18,6 +18,8 @@ #ifndef CAML_OSDEPS_H #define CAML_OSDEPS_H +#ifdef CAML_INTERNALS + #include "misc.h" /* Read at most [n] bytes from file descriptor [fd] into buffer [buf]. @@ -83,4 +85,6 @@ extern int caml_read_directory(char * dirname, struct ext_table * contents); GetModuleFileName under Windows). */ extern int caml_executable_name(char * name, int name_len); +#endif /* CAML_INTERNALS */ + #endif /* CAML_OSDEPS_H */ diff --git a/byterun/caml/prims.h b/byterun/caml/prims.h index 5fdf29f2..147cd98a 100644 --- a/byterun/caml/prims.h +++ b/byterun/caml/prims.h @@ -18,6 +18,8 @@ #ifndef CAML_PRIMS_H #define CAML_PRIMS_H +#ifdef CAML_INTERNALS + typedef value (*c_primitive)(); extern c_primitive caml_builtin_cprim[]; @@ -33,4 +35,6 @@ extern struct ext_table caml_prim_name_table; extern char * caml_section_table; extern asize_t caml_section_table_size; +#endif /* CAML_INTERNALS */ + #endif /* CAML_PRIMS_H */ diff --git a/byterun/caml/reverse.h b/byterun/caml/reverse.h index c1134356..a186078e 100644 --- a/byterun/caml/reverse.h +++ b/byterun/caml/reverse.h @@ -18,6 +18,8 @@ #ifndef CAML_REVERSE_H #define CAML_REVERSE_H +#ifdef CAML_INTERNALS + #define Reverse_16(dst,src) { \ char * _p, * _q; \ char _a; \ @@ -85,4 +87,6 @@ _p[Perm_index(perm_dst, 7)] = _h; \ } +#endif /* CAML_INTERNALS */ + #endif /* CAML_REVERSE_H */ diff --git a/byterun/caml/roots.h b/byterun/caml/roots.h index f8440bec..fed345d3 100644 --- a/byterun/caml/roots.h +++ b/byterun/caml/roots.h @@ -16,6 +16,8 @@ #ifndef CAML_ROOTS_H #define CAML_ROOTS_H +#ifdef CAML_INTERNALS + #include "misc.h" #include "memory.h" @@ -37,4 +39,6 @@ CAMLextern void caml_do_local_roots(scanning_action f, char * bottom_of_stack, CAMLextern void (*caml_scan_roots_hook) (scanning_action); +#endif /* CAML_INTERNALS */ + #endif /* CAML_ROOTS_H */ diff --git a/byterun/caml/signals.h b/byterun/caml/signals.h index ce968251..99924e4f 100644 --- a/byterun/caml/signals.h +++ b/byterun/caml/signals.h @@ -26,18 +26,13 @@ extern "C" { #endif -/* */ +#ifdef CAML_INTERNALS CAMLextern intnat volatile caml_signals_are_pending; CAMLextern intnat volatile caml_pending_signals[]; CAMLextern int volatile caml_something_to_do; extern int volatile caml_requested_major_slice; extern int volatile caml_requested_minor_gc; -/* */ -CAMLextern void caml_enter_blocking_section (void); -CAMLextern void caml_leave_blocking_section (void); - -/* */ void caml_request_major_slice (void); void caml_request_minor_gc (void); CAMLextern int caml_convert_signal_number (int); @@ -52,7 +47,10 @@ CAMLextern void (*caml_enter_blocking_section_hook)(void); CAMLextern void (*caml_leave_blocking_section_hook)(void); CAMLextern int (*caml_try_leave_blocking_section_hook)(void); CAMLextern void (* volatile caml_async_action_hook)(void); -/* */ +#endif /* CAML_INTERNALS */ + +CAMLextern void caml_enter_blocking_section (void); +CAMLextern void caml_leave_blocking_section (void); #ifdef __cplusplus } diff --git a/byterun/caml/signals_machdep.h b/byterun/caml/signals_machdep.h index 6dd2cbc0..ef4e5bbd 100644 --- a/byterun/caml/signals_machdep.h +++ b/byterun/caml/signals_machdep.h @@ -18,6 +18,8 @@ #ifndef CAML_SIGNALS_MACHDEP_H #define CAML_SIGNALS_MACHDEP_H +#ifdef CAML_INTERNALS + #if defined(__GNUC__) && defined(__ATOMIC_SEQ_CST) \ && defined(__GCC_ATOMIC_LONG_LOCK_FREE) @@ -67,4 +69,6 @@ #endif +#endif /* CAML_INTERNALS */ + #endif /* CAML_SIGNALS_MACHDEP_H */ diff --git a/byterun/caml/stack.h b/byterun/caml/stack.h new file mode 100644 index 00000000..fd9d528e --- /dev/null +++ b/byterun/caml/stack.h @@ -0,0 +1,129 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* Machine-dependent interface with the asm code */ + +#ifndef CAML_STACK_H +#define CAML_STACK_H + +#ifdef CAML_INTERNALS + +/* Macros to access the stack frame */ + +#ifdef TARGET_sparc +#define Saved_return_address(sp) *((intnat *)((sp) + 92)) +#define Callback_link(sp) ((struct caml_context *)((sp) + 104)) +#endif + +#ifdef TARGET_i386 +#define Saved_return_address(sp) *((intnat *)((sp) - 4)) +#ifndef SYS_win32 +#define Callback_link(sp) ((struct caml_context *)((sp) + 16)) +#else +#define Callback_link(sp) ((struct caml_context *)((sp) + 8)) +#endif +#endif + +#ifdef TARGET_power +#if defined(MODEL_ppc) +#define Saved_return_address(sp) *((intnat *)((sp) - 4)) +#define Callback_link(sp) ((struct caml_context *)((sp) + 16)) +#elif defined(MODEL_ppc64) +#define Saved_return_address(sp) *((intnat *)((sp) + 16)) +#define Callback_link(sp) ((struct caml_context *)((sp) + (48 + 32))) +#elif defined(MODEL_ppc64le) +#define Saved_return_address(sp) *((intnat *)((sp) + 16)) +#define Callback_link(sp) ((struct caml_context *)((sp) + (32 + 32))) +#else +#error "TARGET_power: wrong MODEL" +#endif +#define Already_scanned(sp, retaddr) ((retaddr) & 1) +#define Mask_already_scanned(retaddr) ((retaddr) & ~1) +#define Mark_scanned(sp, retaddr) Saved_return_address(sp) = (retaddr) | 1 +#endif + +#ifdef TARGET_s390x +#define Saved_return_address(sp) *((intnat *)((sp) - SIZEOF_PTR)) +#define Trap_frame_size 16 +#define Callback_link(sp) ((struct caml_context *)((sp) + Trap_frame_size)) +#endif + +#ifdef TARGET_arm +#define Saved_return_address(sp) *((intnat *)((sp) - 4)) +#define Callback_link(sp) ((struct caml_context *)((sp) + 8)) +#endif + +#ifdef TARGET_amd64 +#define Saved_return_address(sp) *((intnat *)((sp) - 8)) +#define Callback_link(sp) ((struct caml_context *)((sp) + 16)) +#endif + +#ifdef TARGET_arm64 +#define Saved_return_address(sp) *((intnat *)((sp) - 8)) +#define Callback_link(sp) ((struct caml_context *)((sp) + 16)) +#endif + +/* Structure of OCaml callback contexts */ + +struct caml_context { + char * bottom_of_stack; /* beginning of OCaml stack chunk */ + uintnat last_retaddr; /* last return address in OCaml code */ + value * gc_regs; /* pointer to register block */ +#ifdef WITH_SPACETIME + void* trie_node; +#endif +}; + +/* Structure of frame descriptors */ + +typedef struct { + uintnat retaddr; + unsigned short frame_size; + unsigned short num_live; + unsigned short live_ofs[1]; +} frame_descr; + +/* Hash table of frame descriptors */ + +extern frame_descr ** caml_frame_descriptors; +extern int caml_frame_descriptors_mask; + +#define Hash_retaddr(addr) \ + (((uintnat)(addr) >> 3) & caml_frame_descriptors_mask) + +extern void caml_init_frame_descriptors(void); +extern void caml_register_frametable(intnat *); +extern void caml_unregister_frametable(intnat *); +extern void caml_register_dyn_global(void *); + +extern uintnat caml_stack_usage (void); +extern uintnat (*caml_stack_usage_hook)(void); + +/* Declaration of variables used in the asm code */ +extern char * caml_top_of_stack; +extern char * caml_bottom_of_stack; +extern uintnat caml_last_return_address; +extern value * caml_gc_regs; +extern char * caml_exception_pointer; +extern value * caml_globals[]; +extern char caml_globals_map[]; +extern intnat caml_globals_inited; +extern intnat * caml_frametable[]; + +CAMLextern frame_descr * caml_next_frame_descriptor(uintnat * pc, char ** sp); + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_STACK_H */ diff --git a/byterun/caml/stacks.h b/byterun/caml/stacks.h index 9a0f634b..18ec0ac3 100644 --- a/byterun/caml/stacks.h +++ b/byterun/caml/stacks.h @@ -18,6 +18,7 @@ #ifndef CAML_STACKS_H #define CAML_STACKS_H +#ifdef CAML_INTERNALS #include "misc.h" #include "mlvalues.h" @@ -40,4 +41,6 @@ uintnat caml_stack_usage (void); CAMLextern uintnat (*caml_stack_usage_hook)(void); +#endif /* CAML_INTERNALS */ + #endif /* CAML_STACKS_H */ diff --git a/byterun/caml/startup.h b/byterun/caml/startup.h index 2cf111a6..3df4206a 100644 --- a/byterun/caml/startup.h +++ b/byterun/caml/startup.h @@ -16,6 +16,8 @@ #ifndef CAML_STARTUP_H #define CAML_STARTUP_H +#ifdef CAML_INTERNALS + #include "mlvalues.h" #include "exec.h" @@ -37,5 +39,6 @@ extern int32_t caml_seek_optional_section(int fd, struct exec_trailer *trail, extern int32_t caml_seek_section(int fd, struct exec_trailer *trail, char *name); +#endif /* CAML_INTERNALS */ #endif /* CAML_STARTUP_H */ diff --git a/byterun/caml/startup_aux.h b/byterun/caml/startup_aux.h index faa7b7ee..203a47d7 100644 --- a/byterun/caml/startup_aux.h +++ b/byterun/caml/startup_aux.h @@ -13,6 +13,11 @@ /* */ /**************************************************************************/ +#ifndef CAML_STARTUP_AUX_H +#define CAML_STARTUP_AUX_H + +#ifdef CAML_INTERNALS + #include "config.h" extern void caml_init_atom_table (void); @@ -27,3 +32,7 @@ extern uintnat caml_init_major_window; extern uintnat caml_trace_level; extern void caml_parse_ocamlrunparam (void); + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_STARTUP_AUX_H */ diff --git a/byterun/caml/sys.h b/byterun/caml/sys.h index 79ef3ddb..e31e3cef 100644 --- a/byterun/caml/sys.h +++ b/byterun/caml/sys.h @@ -16,15 +16,30 @@ #ifndef CAML_SYS_H #define CAML_SYS_H +#ifdef CAML_INTERNALS + #include "misc.h" +#ifdef __cplusplus +extern "C" { +#endif + #define NO_ARG Val_int(0) CAMLextern void caml_sys_error (value); CAMLextern void caml_sys_io_error (value); -extern void caml_sys_init (char * exe_name, char ** argv); +CAMLextern double caml_sys_time_unboxed(value); +CAMLextern void caml_sys_init (char * exe_name, char ** argv); CAMLextern value caml_sys_exit (value); +extern double caml_sys_time_unboxed(value); +CAMLextern value caml_sys_get_argv(value unit); extern char * caml_exe_name; +#ifdef __cplusplus +} +#endif + +#endif /* CAML_INTERNALS */ + #endif /* CAML_SYS_H */ diff --git a/byterun/caml/ui.h b/byterun/caml/ui.h index 9551ff48..3047ba7f 100644 --- a/byterun/caml/ui.h +++ b/byterun/caml/ui.h @@ -18,6 +18,8 @@ #ifndef CAML_UI_H #define CAML_UI_H +#ifdef CAML_INTERNALS + #include "config.h" void ui_exit (int return_code); @@ -25,4 +27,6 @@ int ui_read (int file_desc, char *buf, unsigned int length); int ui_write (int file_desc, char *buf, unsigned int length); void ui_print_stderr (char *format, void *arg); +#endif /* CAML_INTERNALS */ + #endif /* CAML_UI_H */ diff --git a/byterun/caml/weak.h b/byterun/caml/weak.h index 5cfc8133..a716d212 100644 --- a/byterun/caml/weak.h +++ b/byterun/caml/weak.h @@ -18,6 +18,8 @@ #ifndef CAML_WEAK_H #define CAML_WEAK_H +#ifdef CAML_INTERNALS + #include "mlvalues.h" extern value caml_ephe_list_head; @@ -86,4 +88,6 @@ static inline void caml_ephe_clean (value v){ } } +#endif /* CAML_INTERNALS */ + #endif /* CAML_WEAK_H */ diff --git a/byterun/compact.c b/byterun/compact.c index f9f604b2..cd46623a 100644 --- a/byterun/compact.c +++ b/byterun/compact.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + #include #include "caml/address_class.h" @@ -26,6 +28,7 @@ #include "caml/mlvalues.h" #include "caml/roots.h" #include "caml/weak.h" +#include "caml/compact.h" extern uintnat caml_percent_free; /* major_gc.c */ extern void caml_shrink_heap (char *); /* memory.c */ @@ -46,10 +49,16 @@ extern void caml_shrink_heap (char *); /* memory.c */ XXX (see [caml_register_global_roots]) XXX Should be able to fix it to only assume 2-byte alignment. */ -#define Make_ehd(s,t,c) (((s) << 10) | (t) << 2 | (c)) +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) +#define Make_ehd(s,t,c,p) \ + (((s) << 10) | (t) << 2 | (c) | ((p) << PROFINFO_SHIFT)) +#else +#define Make_ehd(s,t,c,p) (((s) << 10) | (t) << 2 | (c)) +#endif #define Whsize_ehd(h) Whsize_hd (h) #define Wosize_ehd(h) Wosize_hd (h) #define Tag_ehd(h) (((h) >> 2) & 0xFF) +#define Profinfo_ehd(hd) Profinfo_hd(hd) #define Ecolor(w) ((w) & 3) typedef uintnat word; @@ -88,7 +97,7 @@ static void invert_pointer_at (word *p) Hd_val (q) = (header_t) ((word) p | 2); /* Change block header's tag to Infix_tag, and change its size to point to the infix list. */ - *hp = Make_ehd (Wosize_bhsize (q - val), Infix_tag, 3); + *hp = Make_ehd (Wosize_bhsize (q - val), Infix_tag, 3, (uintnat) 0); }else{ Assert (Tag_ehd (*hp) == Infix_tag); /* Point the last of this infix list to the current first infix list of the block. */ @@ -96,7 +105,7 @@ static void invert_pointer_at (word *p) /* Point the head of this infix list to the above. */ Hd_val (q) = (header_t) ((word) p | 2); /* Change block header's size to point to this infix list. */ - *hp = Make_ehd (Wosize_bhsize (q - val), Infix_tag, 3); + *hp = Make_ehd (Wosize_bhsize (q - val), Infix_tag, 3, (uintnat) 0); } } break; @@ -108,7 +117,7 @@ static void invert_pointer_at (word *p) } } -static void invert_root (value v, value *p) +void invert_root (value v, value *p) { invert_pointer_at ((word *) p); } @@ -168,10 +177,10 @@ static void do_compaction (void) if (Is_blue_hd (hd)){ /* Free object. Give it a string tag. */ - Hd_hp (p) = Make_ehd (sz, String_tag, 3); + Hd_hp (p) = Make_ehd (sz, String_tag, 3, (uintnat) 0); }else{ Assert (Is_white_hd (hd)); /* Live object. Keep its tag. */ - Hd_hp (p) = Make_ehd (sz, Tag_hd (hd), 3); + Hd_hp (p) = Make_ehd (sz, Tag_hd (hd), 3, Profinfo_hd (hd)); } p += Whsize_wosize (sz); } @@ -188,7 +197,8 @@ static void do_compaction (void) data structures to find its roots. Fortunately, it doesn't need the headers (see above). */ caml_do_roots (invert_root, 1); - caml_final_do_weak_roots (invert_root); + /* The values to be finalised are not roots but should still be inverted */ + caml_final_invert_finalisable_values (); ch = caml_heap_start; while (ch != NULL){ @@ -263,11 +273,13 @@ static void do_compaction (void) size_t sz; tag_t t; char *newadr; + uintnat profinfo; word *infixes = NULL; while (Ecolor (q) == 0) q = * (word *) q; sz = Whsize_ehd (q); t = Tag_ehd (q); + profinfo = Profinfo_ehd (q); if (t == Infix_tag){ /* Get the original header of this block. */ @@ -285,7 +297,8 @@ static void do_compaction (void) * (word *) q = (word) Val_hp (newadr); q = next; } - *p = Make_header (Wosize_whsize (sz), t, Caml_white); + *p = Make_header_with_profinfo (Wosize_whsize (sz), t, Caml_white, + profinfo); if (infixes != NULL){ /* Rebuild the infix headers and revert the infix pointers. */ @@ -299,6 +312,9 @@ static void do_compaction (void) * (word *) q = (word) Val_hp ((word *) newadr + (infixes - p)); q = next; } Assert (Ecolor (q) == 1 || Ecolor (q) == 3); + /* No need to preserve any profinfo value on the [Infix_tag] + headers; the Spacetime profiling heap snapshot code doesn't + look at them. */ *infixes = Make_header (infixes - p, Infix_tag, Caml_white); infixes = (word *) q; } @@ -511,6 +527,9 @@ void caml_compact_heap_maybe (void) caml_gc_message (0x200, "FL size at phase change = %" ARCH_INTNAT_PRINTF_FORMAT "u words\n", (uintnat) caml_fl_wsz_at_phase_change); + caml_gc_message (0x200, "FL current size = %" + ARCH_INTNAT_PRINTF_FORMAT "u words\n", + (uintnat) caml_fl_cur_wsz); caml_gc_message (0x200, "Estimated overhead = %" ARCH_INTNAT_PRINTF_FORMAT "u%%\n", (uintnat) fp); @@ -524,7 +543,10 @@ void caml_compact_heap_maybe (void) caml_gc_message (0x200, "Measured overhead: %" ARCH_INTNAT_PRINTF_FORMAT "u%%\n", (uintnat) fp); + if (fp >= caml_percent_max) + caml_compact_heap (); + else + caml_gc_message (0x200, "Automatic compaction aborted.\n", 0); - caml_compact_heap (); } } diff --git a/byterun/compare.c b/byterun/compare.c index 42384a47..f34accd7 100644 --- a/byterun/compare.c +++ b/byterun/compare.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + #include #include #include "caml/custom.h" @@ -21,6 +23,10 @@ #include "caml/misc.h" #include "caml/mlvalues.h" +#if defined(LACKS_SANE_NAN) && !defined(isnan) +#define isnan _isnan +#endif + /* Structural comparison on trees. */ struct compare_item { value * v1, * v2; mlsize_t count; }; @@ -174,8 +180,19 @@ static intnat compare_val(value v1, value v2, int total) case Double_tag: { double d1 = Double_val(v1); double d2 = Double_val(v2); +#ifdef LACKS_SANE_NAN + if (isnan(d2)) { + if (! total) return UNORDERED; + if (isnan(d1)) break; + return GREATER; + } else if (isnan(d1)) { + if (! total) return UNORDERED; + return LESS; + } +#endif if (d1 < d2) return LESS; if (d1 > d2) return GREATER; +#ifndef LACKS_SANE_NAN if (d1 != d2) { if (! total) return UNORDERED; /* One or both of d1 and d2 is NaN. Order according to the @@ -184,6 +201,7 @@ static intnat compare_val(value v1, value v2, int total) if (d2 == d2) return LESS; /* d2 is not NaN, d1 is NaN */ /* d1 and d2 are both NaN, thus equal: continue comparison */ } +#endif break; } case Double_array_tag: { @@ -194,14 +212,26 @@ static intnat compare_val(value v1, value v2, int total) for (i = 0; i < sz1; i++) { double d1 = Double_field(v1, i); double d2 = Double_field(v2, i); +#ifdef LACKS_SANE_NAN + if (isnan(d2)) { + if (! total) return UNORDERED; + if (isnan(d1)) break; + return GREATER; + } else if (isnan(d1)) { + if (! total) return UNORDERED; + return LESS; + } +#endif if (d1 < d2) return LESS; if (d1 > d2) return GREATER; +#ifndef LACKS_SANE_NAN if (d1 != d2) { if (! total) return UNORDERED; /* See comment for Double_tag case */ if (d1 == d1) return GREATER; if (d2 == d2) return LESS; } +#endif } break; } diff --git a/byterun/custom.c b/byterun/custom.c index 3875a4e5..2198d62d 100644 --- a/byterun/custom.c +++ b/byterun/custom.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + #include #include "caml/alloc.h" diff --git a/byterun/debugger.c b/byterun/debugger.c index 5e61584b..2edbaa0c 100644 --- a/byterun/debugger.c +++ b/byterun/debugger.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Interface with the byte-code debugger */ #ifdef _WIN32 @@ -220,7 +222,7 @@ void caml_debugger_init(void) static value getval(struct channel *chan) { value res; - if (caml_really_getblock(chan, (char *) &res, sizeof(res)) == 0) + if (caml_really_getblock(chan, (char *) &res, sizeof(res)) < sizeof(res)) caml_raise_end_of_file(); /* Bad, but consistent with caml_getword */ return res; } @@ -267,19 +269,19 @@ void caml_debugger(enum event_kind event) case PROGRAM_START: /* Nothing to report */ goto command_loop; case EVENT_COUNT: - putch(dbg_out, REP_EVENT); + caml_putch(dbg_out, REP_EVENT); break; case BREAKPOINT: - putch(dbg_out, REP_BREAKPOINT); + caml_putch(dbg_out, REP_BREAKPOINT); break; case PROGRAM_EXIT: - putch(dbg_out, REP_EXITED); + caml_putch(dbg_out, REP_EXITED); break; case TRAP_BARRIER: - putch(dbg_out, REP_TRAP); + caml_putch(dbg_out, REP_TRAP); break; case UNCAUGHT_EXC: - putch(dbg_out, REP_UNCAUGHT_EXC); + caml_putch(dbg_out, REP_UNCAUGHT_EXC); break; } caml_putword(dbg_out, caml_event_count); @@ -297,7 +299,7 @@ void caml_debugger(enum event_kind event) /* Read and execute the commands sent by the debugger */ while(1) { - switch(getch(dbg_in)) { + switch(caml_getch(dbg_in)) { case REQ_SET_EVENT: pos = caml_getword(dbg_in); Assert (pos >= 0); @@ -405,11 +407,11 @@ void caml_debugger(enum event_kind event) val = getval(dbg_in); i = caml_getword(dbg_in); if (Tag_val(val) != Double_array_tag) { - putch(dbg_out, 0); + caml_putch(dbg_out, 0); putval(dbg_out, Field(val, i)); } else { double d = Double_field(val, i); - putch(dbg_out, 1); + caml_putch(dbg_out, 1); caml_really_putblock(dbg_out, (char *) &d, 8); } caml_flush(dbg_out); diff --git a/byterun/dynlink.c b/byterun/dynlink.c index 7142769c..f80d1f7f 100644 --- a/byterun/dynlink.c +++ b/byterun/dynlink.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Dynamic loading of C primitives. */ #include diff --git a/byterun/extern.c b/byterun/extern.c index 221e206d..eca115d8 100644 --- a/byterun/extern.c +++ b/byterun/extern.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Structured output */ /* The interface of this file is "caml/intext.h" */ @@ -94,7 +96,6 @@ CAMLnoreturn_start static void extern_stack_overflow(void) CAMLnoreturn_end; -static struct code_fragment * extern_find_code(char *addr); static void extern_replay_trail(void); static void free_extern_output(void); @@ -383,6 +384,8 @@ static void writecode64(int code, intnat val) /* Marshal the given value in the output buffer */ +int caml_extern_allow_out_of_heap = 0; + static void extern_rec(value v) { struct code_fragment * cf; @@ -409,7 +412,7 @@ static void extern_rec(value v) writecode32(CODE_INT32, n); goto next_item; } - if (Is_in_value_area(v)) { + if (Is_in_value_area(v) || caml_extern_allow_out_of_heap) { header_t hd = Hd_val(v); tag_t tag = Tag_hd(hd); mlsize_t sz = Wosize_hd(hd); @@ -431,7 +434,11 @@ static void extern_rec(value v) if (tag < 16) { write(PREFIX_SMALL_BLOCK + tag); } else { +#if !(defined(NATIVE_CODE) && defined(WITH_SPACETIME)) writecode32(CODE_BLOCK32, hd); +#else + writecode32(CODE_BLOCK32, Hd_no_profinfo(hd)); +#endif } goto next_item; } @@ -544,13 +551,18 @@ static void extern_rec(value v) write(PREFIX_SMALL_BLOCK + tag + (sz << 4)); } else { #ifdef ARCH_SIXTYFOUR +#if !(defined(NATIVE_CODE) && defined(WITH_SPACETIME)) + header_t hd_erased = hd; +#else + header_t hd_erased = Hd_no_profinfo(hd); +#endif if (sz > 0x3FFFFF && (extern_flags & COMPAT_32)) extern_failwith("output_value: array cannot be read back on " "32-bit platform"); - if (hd < (uintnat)1 << 32) - writecode32(CODE_BLOCK32, Whitehd_hd (hd)); + if (hd_erased < (uintnat)1 << 32) + writecode32(CODE_BLOCK32, Whitehd_hd (hd_erased)); else - writecode64(CODE_BLOCK64, Whitehd_hd (hd)); + writecode64(CODE_BLOCK64, Whitehd_hd (hd_erased)); #else writecode32(CODE_BLOCK32, Whitehd_hd (hd)); #endif @@ -572,7 +584,7 @@ static void extern_rec(value v) } } } - else if ((cf = extern_find_code((char *) v)) != NULL) { + else if ((cf = caml_extern_find_code((char *) v)) != NULL) { if ((extern_flags & CLOSURES) == 0) extern_invalid_argument("output_value: functional value"); writecode32(CODE_CODEPOINTER, (char *) v - cf->code_start); @@ -889,7 +901,7 @@ CAMLexport void caml_serialize_block_float_8(void * data, intnat len) /* Find where a code pointer comes from */ -static struct code_fragment * extern_find_code(char *addr) +CAMLexport struct code_fragment * caml_extern_find_code(char *addr) { int i; for (i = caml_code_fragments_table.size - 1; i >= 0; i--) { diff --git a/byterun/fail.c b/byterun/fail.c index 8ba6c767..80eca18a 100644 --- a/byterun/fail.c +++ b/byterun/fail.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Raising exceptions from C. */ #include diff --git a/byterun/finalise.c b/byterun/finalise.c index 9c707c1d..91088cf1 100644 --- a/byterun/finalise.c +++ b/byterun/finalise.c @@ -13,13 +13,21 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Handling of finalised values. */ #include "caml/callback.h" +#include "caml/compact.h" #include "caml/fail.h" +#include "caml/finalise.h" +#include "caml/minor_gc.h" #include "caml/mlvalues.h" #include "caml/roots.h" #include "caml/signals.h" +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) +#include "../asmrun/spacetime.h" +#endif struct final { value fun; @@ -27,13 +35,24 @@ struct final { int offset; }; -static struct final *final_table = NULL; -static uintnat old = 0, young = 0, size = 0; -/* [0..old) : finalisable set - [old..young) : recent set +struct finalisable { + struct final *table; + uintnat old; + uintnat young; + uintnat size; +}; +/* [0..old) : finalisable set, the values are in the major heap + [old..young) : recent set, the values could be in the minor heap [young..size) : free space + + The element of the finalisable set are moved to the finalising set + below when the value are unreachable (for the first or last time). + */ +static struct finalisable finalisable_first = {NULL,0,0,0}; +static struct finalisable finalisable_last = {NULL,0,0,0}; + struct to_do { struct to_do *next; int size; @@ -42,6 +61,13 @@ struct to_do { static struct to_do *to_do_hd = NULL; static struct to_do *to_do_tl = NULL; +/* + to_do_hd: head of the list of finalisation functions that can be run. + to_do_tl: tail of the list of finalisation functions that can be run. + + It is the finalising set. +*/ + /* [size] is a number of elements for the [to_do.item] array */ static void alloc_to_do (int size) @@ -62,48 +88,80 @@ static void alloc_to_do (int size) } /* Find white finalisable values, move them to the finalising set, and - darken them. + darken them (if darken_value is true). */ -void caml_final_update (void) +static void generic_final_update (struct finalisable * final, int darken_value) { uintnat i, j, k; uintnat todo_count = 0; - Assert (old <= young); - for (i = 0; i < old; i++){ - Assert (Is_block (final_table[i].val)); - Assert (Is_in_heap (final_table[i].val)); - if (Is_white_val (final_table[i].val)) ++ todo_count; + Assert (final->old <= final->young); + for (i = 0; i < final->old; i++){ + Assert (Is_block (final->table[i].val)); + Assert (Is_in_heap (final->table[i].val)); + if (Is_white_val (final->table[i].val)){ + ++ todo_count; + } } + /** invariant: + - 0 <= j <= i /\ 0 <= k <= i /\ 0 <= k <= todo_count + - i : index in final_table, before i all the values are black + (alive or in the minor heap) or the finalizer have been copied + in to_do_tl. + - j : index in final_table, before j all the values are black + (alive or in the minor heap), next available slot. + - k : index in to_do_tl, next available slot. + */ if (todo_count > 0){ alloc_to_do (todo_count); j = k = 0; - for (i = 0; i < old; i++){ - Assert (Is_block (final_table[i].val)); - Assert (Is_in_heap (final_table[i].val)); - Assert (Tag_val (final_table[i].val) != Forward_tag); - if (Is_white_val (final_table[i].val)){ - to_do_tl->item[k++] = final_table[i]; + for (i = 0; i < final->old; i++){ + Assert (Is_block (final->table[i].val)); + Assert (Is_in_heap (final->table[i].val)); + Assert (Tag_val (final->table[i].val) != Forward_tag); + if(Is_white_val (final->table[i].val)){ + /** dead */ + to_do_tl->item[k] = final->table[i]; + if(!darken_value){ + /* The value is not darken so the finalisation function + is called with unit not with the value */ + to_do_tl->item[k].val = Val_unit; + to_do_tl->item[k].offset = 0; + }; + k++; }else{ - final_table[j++] = final_table[i]; + /** alive */ + final->table[j++] = final->table[i]; } } - CAMLassert (i == old); - old = j; - for(;i < young; i++){ - final_table[j++] = final_table[i]; + CAMLassert (i == final->old); + CAMLassert (k == todo_count); + final->old = j; + for(;i < final->young; i++){ + final->table[j++] = final->table[i]; } - young = j; + final->young = j; to_do_tl->size = k; - for (i = 0; i < k; i++){ - /* Note that item may already be dark due to multiple entries in - the final table. */ - caml_darken (to_do_tl->item[i].val, NULL); + if(darken_value){ + for (i = 0; i < k; i++){ + /* Note that item may already be dark due to multiple entries in + the final table. */ + caml_darken (to_do_tl->item[i].val, NULL); + } } } } +void caml_final_update_mark_phase (){ + generic_final_update(&finalisable_first, /* darken_value */ 1); +} + +void caml_final_update_clean_phase (){ + generic_final_update(&finalisable_last, /* darken_value */ 0); +} + + static int running_finalisation_function = 0; /* Call the finalisation functions for the finalising set. @@ -113,6 +171,9 @@ void caml_final_do_calls (void) { struct final f; value res; +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) + void* saved_spacetime_trie_node_ptr; +#endif if (running_finalisation_function) return; if (to_do_hd != NULL){ @@ -130,7 +191,17 @@ void caml_final_do_calls (void) -- to_do_hd->size; f = to_do_hd->item[to_do_hd->size]; running_finalisation_function = 1; +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) + /* We record the finaliser's execution separately. + (The code of [caml_callback_exn] will do the hard work of finding + the correct place in the trie.) */ + saved_spacetime_trie_node_ptr = caml_spacetime_trie_node_ptr; + caml_spacetime_trie_node_ptr = caml_spacetime_finaliser_trie_root; +#endif res = caml_callback_exn (f.fun, f.val + f.offset); +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) + caml_spacetime_trie_node_ptr = saved_spacetime_trie_node_ptr; +#endif running_finalisation_function = 0; if (Is_exception_result (res)) caml_raise (Extract_exception (res)); } @@ -144,15 +215,23 @@ void caml_final_do_calls (void) /* Call [*f] on the closures of the finalisable set and the closures and values of the finalising set. - This is called by the major GC through [caml_darken_all_roots]. + This is called by the major GC [caml_darken_all_roots] + and by the compactor through [caml_do_roots] */ -void caml_final_do_strong_roots (scanning_action f) +void caml_final_do_roots (scanning_action f) { uintnat i; struct to_do *todo; - Assert (old <= young); - for (i = 0; i < young; i++) Call_action (f, final_table[i].fun); + Assert (finalisable_first.old <= finalisable_first.young); + for (i = 0; i < finalisable_first.young; i++){ + Call_action (f, finalisable_first.table[i].fun); + }; + + Assert (finalisable_last.old <= finalisable_last.young); + for (i = 0; i < finalisable_last.young; i++){ + Call_action (f, finalisable_last.table[i].fun); + }; for (todo = to_do_hd; todo != NULL; todo = todo->next){ for (i = 0; i < todo->size; i++){ @@ -162,29 +241,122 @@ void caml_final_do_strong_roots (scanning_action f) } } -/* Call [*f] on the values of the finalisable set. - This is called directly by the compactor. +/* Call invert_root on the values of the finalisable set. This is called + directly by the compactor. */ -void caml_final_do_weak_roots (scanning_action f) +void caml_final_invert_finalisable_values () { uintnat i; - CAMLassert (old <= young); - for (i = 0; i < young; i++) Call_action (f, final_table[i].val); + CAMLassert (finalisable_first.old <= finalisable_first.young); + for (i = 0; i < finalisable_first.young; i++){ + invert_root(finalisable_first.table[i].val, + &finalisable_first.table[i].val); + }; + + CAMLassert (finalisable_last.old <= finalisable_last.young); + for (i = 0; i < finalisable_last.young; i++){ + invert_root(finalisable_last.table[i].val, + &finalisable_last.table[i].val); + }; } -/* Call [*f] on the closures and values of the recent set. +/* Call [caml_oldify_one] on the closures and values of the recent set. This is called by the minor GC through [caml_oldify_local_roots]. */ -void caml_final_do_young_roots (scanning_action f) +void caml_final_oldify_young_roots () { uintnat i; - Assert (old <= young); - for (i = old; i < young; i++){ - Call_action (f, final_table[i].fun); - Call_action (f, final_table[i].val); + Assert (finalisable_first.old <= finalisable_first.young); + for (i = finalisable_first.old; i < finalisable_first.young; i++){ + caml_oldify_one(finalisable_first.table[i].fun, + &finalisable_first.table[i].fun); + caml_oldify_one(finalisable_first.table[i].val, + &finalisable_first.table[i].val); + } + + Assert (finalisable_last.old <= finalisable_last.young); + for (i = finalisable_last.old; i < finalisable_last.young; i++){ + caml_oldify_one(finalisable_last.table[i].fun, + &finalisable_last.table[i].fun); + } + +} + +static void generic_final_minor_update (struct finalisable * final) +{ + uintnat i, j, k; + uintnat todo_count = 0; + + Assert (final->old <= final->young); + for (i = final->old; i < final->young; i++){ + Assert (Is_block (final->table[i].val)); + Assert (Is_in_heap_or_young (final->table[i].val)); + if (Is_young(final->table[i].val) && Hd_val(final->table[i].val) != 0){ + ++ todo_count; + } + } + + /** invariant: + - final->old <= j <= i /\ final->old <= k <= i /\ 0 <= k <= todo_count + - i : index in final_table, before i all the values are alive + or the finalizer have been copied in to_do_tl. + - j : index in final_table, before j all the values are alive, + next available slot. + - k : index in to_do_tl, next available slot. + */ + if (todo_count > 0){ + alloc_to_do (todo_count); + k = 0; + j = final->old; + for (i = final->old; i < final->young; i++){ + Assert (Is_block (final->table[i].val)); + Assert (Is_in_heap_or_young (final->table[i].val)); + Assert (Tag_val (final->table[i].val) != Forward_tag); + if(Is_young(final->table[j].val) && Hd_val(final->table[i].val) != 0){ + /** dead */ + to_do_tl->item[k] = final->table[i]; + /* The finalisation function is called with unit not with the value */ + to_do_tl->item[k].val = Val_unit; + to_do_tl->item[k].offset = 0; + k++; + }else{ + /** alive */ + final->table[j++] = final->table[i]; + } + } + CAMLassert (i == final->young); + CAMLassert (k == todo_count); + final->young = j; + to_do_tl->size = todo_count; + } + + /** update the minor value to the copied major value */ + for (i = final->old; i < final->young; i++){ + Assert (Is_block (final->table[i].val)); + Assert (Is_in_heap_or_young (final->table[i].val)); + if (Is_young(final->table[i].val)) { + CAMLassert (Hd_val(final->table[i].val) == 0); + final->table[i].val = Field(final->table[i].val,0); + } } + + /** check invariant */ + Assert (final->old <= final->young); + for (i = 0; i < final->young; i++){ + CAMLassert( Is_in_heap(final->table[i].val) ); + }; + +} + +/* At the end of minor collection update the finalise_last roots in + minor heap when moved to major heap or moved them to the finalising + set when dead. +*/ +void caml_final_update_minor_roots () +{ + generic_final_minor_update(&finalisable_last); } /* Empty the recent set into the finalisable set. @@ -193,11 +365,12 @@ void caml_final_do_young_roots (scanning_action f) */ void caml_final_empty_young (void) { - old = young; + finalisable_first.old = finalisable_first.young; + finalisable_last.old = finalisable_last.young; } /* Put (f,v) in the recent set. */ -CAMLprim value caml_final_register (value f, value v) +static void generic_final_register (struct finalisable *final, value f, value v) { if (!Is_block (v) || !Is_in_heap_or_young(v) @@ -206,38 +379,65 @@ CAMLprim value caml_final_register (value f, value v) || Tag_val (v) == Forward_tag) { caml_invalid_argument ("Gc.finalise"); } - Assert (old <= young); + Assert (final->old <= final->young); - if (young >= size){ - if (final_table == NULL){ + if (final->young >= final->size){ + if (final->table == NULL){ uintnat new_size = 30; - final_table = caml_stat_alloc (new_size * sizeof (struct final)); - Assert (old == 0); - Assert (young == 0); - size = new_size; + final->table = caml_stat_alloc (new_size * sizeof (struct final)); + Assert (final->old == 0); + Assert (final->young == 0); + final->size = new_size; }else{ - uintnat new_size = size * 2; - final_table = caml_stat_resize (final_table, + uintnat new_size = final->size * 2; + final->table = caml_stat_resize (final->table, new_size * sizeof (struct final)); - size = new_size; + final->size = new_size; } } - Assert (young < size); - final_table[young].fun = f; + Assert (final->young < final->size); + final->table[final->young].fun = f; if (Tag_val (v) == Infix_tag){ - final_table[young].offset = Infix_offset_val (v); - final_table[young].val = v - Infix_offset_val (v); + final->table[final->young].offset = Infix_offset_val (v); + final->table[final->young].val = v - Infix_offset_val (v); }else{ - final_table[young].offset = 0; - final_table[young].val = v; + final->table[final->young].offset = 0; + final->table[final->young].val = v; } - ++ young; + ++ final->young; + +} + +CAMLprim value caml_final_register (value f, value v){ + generic_final_register(&finalisable_first, f, v); + return Val_unit; +} +CAMLprim value caml_final_register_called_without_value (value f, value v){ + generic_final_register(&finalisable_last, f, v); return Val_unit; } + CAMLprim value caml_final_release (value unit) { running_finalisation_function = 0; return Val_unit; } + +static void gen_final_invariant_check(struct finalisable *final){ + uintnat i; + + CAMLassert (final->old <= final->young); + for (i = 0; i < final->old; i++){ + CAMLassert( Is_in_heap(final->table[i].val) ); + }; + for (i = final->old; i < final->young; i++){ + CAMLassert( Is_in_heap_or_young(final->table[i].val) ); + }; +} + +void caml_final_invariant_check(void){ + gen_final_invariant_check(&finalisable_first); + gen_final_invariant_check(&finalisable_last); +} diff --git a/byterun/fix_code.c b/byterun/fix_code.c index 45d52cad..b55d8ffb 100644 --- a/byterun/fix_code.c +++ b/byterun/fix_code.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Handling of blocks of bytecode (endianness switch, threading). */ #include "caml/config.h" diff --git a/byterun/floats.c b/byterun/floats.c index 41204da2..8792b252 100644 --- a/byterun/floats.c +++ b/byterun/floats.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* The interface of this file is in "caml/mlvalues.h" and "caml/alloc.h" */ #include @@ -241,6 +243,7 @@ static int caml_float_of_hex(const char * s, double * res) } } } + if (n_bits == 0) return -1; /* Convert mantissa to FP. We use a signed conversion because we can (m has 60 bits at most) and because it is faster on several architectures. */ @@ -555,34 +558,41 @@ CAMLprim value caml_copysign_float(value f, value g) return caml_copy_double(caml_copysign(Double_val(f), Double_val(g))); } -CAMLprim value caml_eq_float(value f, value g) -{ - return Val_bool(Double_val(f) == Double_val(g)); -} +#ifdef LACKS_SANE_NAN -CAMLprim value caml_neq_float(value f, value g) +CAMLprim value caml_neq_float(value vf, value vg) { - return Val_bool(Double_val(f) != Double_val(g)); + double f = Double_val(vf); + double g = Double_val(vg); + return Val_bool(isnan(f) || isnan(g) || f != g); } -CAMLprim value caml_le_float(value f, value g) -{ - return Val_bool(Double_val(f) <= Double_val(g)); +#define DEFINE_NAN_CMP(op) (value vf, value vg) \ +{ \ + double f = Double_val(vf); \ + double g = Double_val(vg); \ + return Val_bool(!isnan(f) && !isnan(g) && f op g); \ } -CAMLprim value caml_lt_float(value f, value g) +intnat caml_float_compare_unboxed(double f, double g) { - return Val_bool(Double_val(f) < Double_val(g)); + /* Insane => nan == everything && nan < everything && nan > everything */ + if (isnan(f) && isnan(g)) return 0; + if (!isnan(g) && f < g) return -1; + if (f != g) return 1; + return 0; } -CAMLprim value caml_ge_float(value f, value g) +#else + +CAMLprim value caml_neq_float(value f, value g) { - return Val_bool(Double_val(f) >= Double_val(g)); + return Val_bool(Double_val(f) != Double_val(g)); } -CAMLprim value caml_gt_float(value f, value g) -{ - return Val_bool(Double_val(f) > Double_val(g)); +#define DEFINE_NAN_CMP(op) (value f, value g) \ +{ \ + return Val_bool(Double_val(f) op Double_val(g)); \ } intnat caml_float_compare_unboxed(double f, double g) @@ -594,6 +604,14 @@ intnat caml_float_compare_unboxed(double f, double g) return (f > g) - (f < g) + (f == f) - (g == g); } +#endif + +CAMLprim value caml_eq_float DEFINE_NAN_CMP(==) +CAMLprim value caml_le_float DEFINE_NAN_CMP(<=) +CAMLprim value caml_lt_float DEFINE_NAN_CMP(<) +CAMLprim value caml_ge_float DEFINE_NAN_CMP(>=) +CAMLprim value caml_gt_float DEFINE_NAN_CMP(>) + CAMLprim value caml_float_compare(value vf, value vg) { return Val_int(caml_float_compare_unboxed(Double_val(vf),Double_val(vg))); diff --git a/byterun/freelist.c b/byterun/freelist.c index eaac36c4..3633d77b 100644 --- a/byterun/freelist.c +++ b/byterun/freelist.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + #define FREELIST_DEBUG 0 #if FREELIST_DEBUG #include @@ -587,7 +589,8 @@ void caml_make_free_blocks (value *p, mlsize_t size, int do_merge, int color) }else{ sz = size; } - *(header_t *)p = Make_header (Wosize_whsize (sz), 0, color); + *(header_t *)p = + Make_header (Wosize_whsize (sz), 0, color); if (do_merge) caml_fl_merge_block (Val_hp (p)); size -= sz; p += sz; diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c index 51a2d79e..4e3f833c 100644 --- a/byterun/gc_ctrl.c +++ b/byterun/gc_ctrl.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + #include "caml/alloc.h" #include "caml/backtrace.h" #include "caml/compact.h" @@ -29,7 +31,7 @@ #include "caml/mlvalues.h" #include "caml/signals.h" #ifdef NATIVE_CODE -#include "stack.h" +#include "caml/stack.h" #else #include "caml/stacks.h" #endif @@ -213,6 +215,10 @@ static value heap_stats (int returnstats) chunk = Chunk_next (chunk); } +#ifdef DEBUG + caml_final_invariant_check(); +#endif + Assert (heap_chunks == caml_stat_heap_chunks); Assert (live_words + free_words + fragments == caml_stat_heap_wsz); @@ -307,6 +313,18 @@ CAMLprim value caml_gc_quick_stat(value v) CAMLreturn (res); } +double caml_gc_minor_words_unboxed() +{ + return (caml_stat_minor_words + + (double) (caml_young_alloc_end - caml_young_ptr)); +} + +CAMLprim value caml_gc_minor_words(value v) +{ + CAMLparam0 (); /* v is ignored */ + CAMLreturn(caml_copy_double(caml_gc_minor_words_unboxed())); +} + CAMLprim value caml_gc_counters(value v) { CAMLparam0 (); /* v is ignored */ @@ -462,7 +480,7 @@ static void test_and_compact (void) caml_gc_message (0x200, "Estimated overhead (lower bound) = %" ARCH_INTNAT_PRINTF_FORMAT "u%%\n", (uintnat) fp); - if (fp >= caml_percent_max && caml_stat_heap_chunks > 1){ + if (fp >= caml_percent_max){ caml_gc_message (0x200, "Automatic compaction triggered.\n", 0); caml_compact_heap (); } @@ -648,7 +666,8 @@ CAMLprim value caml_ml_enable_runtime_warnings(value vbool) return Val_unit; } -CAMLprim value caml_ml_runtime_warnings_enabled(value vbool) +CAMLprim value caml_ml_runtime_warnings_enabled(value unit) { + CAMLassert (unit == Val_unit); return Val_bool(caml_runtime_warnings); } diff --git a/byterun/globroots.c b/byterun/globroots.c index 138b808b..44493dbe 100644 --- a/byterun/globroots.c +++ b/byterun/globroots.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Registration of global memory roots */ #include "caml/memory.h" @@ -216,9 +218,9 @@ CAMLexport void caml_remove_generational_global_root(value *r) { value v = *r; if (Is_block(v)) { - if (Is_young(v)) + if (Is_in_heap_or_young(v)) caml_delete_global_root(&caml_global_roots_young, r); - else if (Is_in_heap(v)) + if (Is_in_heap(v)) caml_delete_global_root(&caml_global_roots_old, r); } } @@ -254,9 +256,9 @@ CAMLexport void caml_modify_generational_global_root(value *r, value newval) the root should be removed. If [oldval] is young, this will happen anyway at the next minor collection, but it is safer to delete it here. */ - if (Is_young(oldval)) + if (Is_in_heap_or_young(oldval)) caml_delete_global_root(&caml_global_roots_young, r); - else if (Is_in_heap(oldval)) + if (Is_in_heap(oldval)) caml_delete_global_root(&caml_global_roots_old, r); } /* end PR#4704 */ diff --git a/byterun/hash.c b/byterun/hash.c index 6089dba2..f59c8fbc 100644 --- a/byterun/hash.c +++ b/byterun/hash.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* The generic hashing primitive */ /* The interface of this file is in "mlvalues.h" (for [caml_hash_variant]) diff --git a/byterun/instrtrace.c b/byterun/instrtrace.c index bf2d3038..c2ad8348 100644 --- a/byterun/instrtrace.c +++ b/byterun/instrtrace.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Trace the instructions executed */ #ifdef DEBUG diff --git a/byterun/intern.c b/byterun/intern.c index 96196ff2..9c6c4cea 100644 --- a/byterun/intern.c +++ b/byterun/intern.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Structured input, compact format */ /* The interface of this file is "caml/intext.h" */ @@ -363,7 +365,7 @@ static void intern_rec(value *dest) } else { v = Val_hp(intern_dest); if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; - *intern_dest = Make_header(size, tag, intern_color); + *intern_dest = Make_header_allocated_here(size, tag, intern_color); intern_dest += 1 + size; /* For objects, we need to freshen the oid */ if (tag == Object_tag) { @@ -393,7 +395,7 @@ static void intern_rec(value *dest) size = (len + sizeof(value)) / sizeof(value); v = Val_hp(intern_dest); if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; - *intern_dest = Make_header(size, String_tag, intern_color); + *intern_dest = Make_header_allocated_here(size, String_tag, intern_color); intern_dest += 1 + size; Field(v, size - 1) = 0; ofs_ind = Bsize_wsize(size) - 1; @@ -465,7 +467,8 @@ static void intern_rec(value *dest) case CODE_DOUBLE_BIG: v = Val_hp(intern_dest); if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; - *intern_dest = Make_header(Double_wosize, Double_tag, intern_color); + *intern_dest = Make_header_allocated_here(Double_wosize, Double_tag, + intern_color); intern_dest += 1 + Double_wosize; readfloat((double *) v, code); break; @@ -476,7 +479,8 @@ static void intern_rec(value *dest) size = len * Double_wosize; v = Val_hp(intern_dest); if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; - *intern_dest = Make_header(size, Double_array_tag, intern_color); + *intern_dest = Make_header_allocated_here(size, Double_array_tag, + intern_color); intern_dest += 1 + size; readfloats((double *) v, len, code); break; @@ -527,7 +531,8 @@ static void intern_rec(value *dest) size = 1 + (size + sizeof(value) - 1) / sizeof(value); v = Val_hp(intern_dest); if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; - *intern_dest = Make_header(size, Custom_tag, intern_color); + *intern_dest = Make_header_allocated_here(size, Custom_tag, + intern_color); Custom_ops_val(v) = ops; if (ops->finalize != NULL && Is_young(v)) { @@ -554,7 +559,8 @@ static void intern_rec(value *dest) intern_free_stack(); } -static void intern_alloc(mlsize_t whsize, mlsize_t num_objects) +static void intern_alloc(mlsize_t whsize, mlsize_t num_objects, + int outside_heap) { mlsize_t wosize; @@ -564,7 +570,7 @@ static void intern_alloc(mlsize_t whsize, mlsize_t num_objects) return; } wosize = Wosize_whsize(whsize); - if (wosize > Max_wosize) { + if (wosize > Max_wosize || outside_heap) { /* Round desired size up to next page */ asize_t request = ((Bsize_wsize(whsize) + Page_size - 1) >> Page_log) << Page_log; @@ -573,7 +579,8 @@ static void intern_alloc(mlsize_t whsize, mlsize_t num_objects) intern_cleanup(); caml_raise_out_of_memory(); } - intern_color = caml_allocation_color(intern_extra_block); + intern_color = + outside_heap ? Caml_black : caml_allocation_color(intern_extra_block); intern_dest = (header_t *) intern_extra_block; Assert (intern_block == 0); } else { @@ -686,8 +693,9 @@ static void caml_parse_header(char * fun_name, /* Reading from a channel */ -value caml_input_val(struct channel *chan) +static value caml_input_val_core(struct channel *chan, int outside_heap) { + intnat r; char header[32]; struct marshal_header h; char * block; @@ -696,12 +704,15 @@ value caml_input_val(struct channel *chan) if (! caml_channel_binary_mode(chan)) caml_failwith("input_value: not a binary channel"); /* Read and parse the header */ - if (caml_really_getblock(chan, header, 20) == 0) + r = caml_really_getblock(chan, header, 20); + if (r == 0) + caml_raise_end_of_file(); + else if (r < 20) caml_failwith("input_value: truncated object"); intern_src = (unsigned char *) header; if (read32u() == Intext_magic_number_big) { /* Finish reading the header */ - if (caml_really_getblock(chan, header + 20, 32 - 20) == 0) + if (caml_really_getblock(chan, header + 20, 32 - 20) < 32 - 20) caml_failwith("input_value: truncated object"); } intern_src = (unsigned char *) header; @@ -712,21 +723,32 @@ value caml_input_val(struct channel *chan) can take place (via signal handlers or context switching in systhreads), and [intern_input] may change. So, wait until [caml_really_getblock] is over before using [intern_input] and the other global vars. */ - if (caml_really_getblock(chan, block, h.data_len) == 0) { + if (caml_really_getblock(chan, block, h.data_len) < h.data_len) { caml_stat_free(block); caml_failwith("input_value: truncated object"); } /* Initialize global state */ intern_init(block, block); - intern_alloc(h.whsize, h.num_objects); + intern_alloc(h.whsize, h.num_objects, outside_heap); /* Fill it in */ intern_rec(&res); - intern_add_to_heap(h.whsize); + if (!outside_heap) { + intern_add_to_heap(h.whsize); + } else { + caml_disown_for_heap(intern_extra_block); + intern_extra_block = NULL; + intern_block = 0; + } /* Free everything */ intern_cleanup(); return caml_check_urgent_gc(res); } +value caml_input_val(struct channel* chan) +{ + return caml_input_val_core(chan, 0); +} + CAMLprim value caml_input_value(value vchan) { CAMLparam1 (vchan); @@ -741,6 +763,18 @@ CAMLprim value caml_input_value(value vchan) /* Reading from memory-resident blocks */ +CAMLprim value caml_input_value_to_outside_heap(value vchan) +{ + CAMLparam1 (vchan); + struct channel * chan = Channel(vchan); + CAMLlocal1 (res); + + Lock(chan); + res = caml_input_val_core(chan, 1); + Unlock(chan); + CAMLreturn (res); +} + CAMLexport value caml_input_val_from_string(value str, intnat ofs) { CAMLparam1 (str); @@ -753,7 +787,7 @@ CAMLexport value caml_input_val_from_string(value str, intnat ofs) if (ofs + h.header_len + h.data_len > caml_string_length(str)) caml_failwith("input_val_from_string: bad length"); /* Allocate result */ - intern_alloc(h.whsize, h.num_objects); + intern_alloc(h.whsize, h.num_objects, 0); intern_src = &Byte_u(str, ofs + h.header_len); /* If a GC occurred */ /* Fill it in */ intern_rec(&obj); @@ -772,7 +806,7 @@ static value input_val_from_block(struct marshal_header * h) { value obj; /* Allocate result */ - intern_alloc(h->whsize, h->num_objects); + intern_alloc(h->whsize, h->num_objects, 0); /* Fill it in */ intern_rec(&obj); intern_add_to_heap(h->whsize); diff --git a/byterun/interp.c b/byterun/interp.c index f039b9a6..9b3e0ac2 100644 --- a/byterun/interp.c +++ b/byterun/interp.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* The bytecode interpreter */ #include #include "caml/alloc.h" diff --git a/byterun/ints.c b/byterun/ints.c index 6141f2b9..c49f42f0 100644 --- a/byterun/ints.c +++ b/byterun/ints.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + #include #include #include "caml/alloc.h" @@ -499,18 +501,25 @@ value caml_int64_direct_bswap(value v) { return caml_swap64(v); } #endif +/* Microsoft introduced the LL integer literal suffix in Visual C++ .NET 2003 */ +#if defined(_MSC_VER) && _MSC_VER < 1400 +#define INT64_LITERAL(s) s ## i64 +#else +#define INT64_LITERAL(s) s ## LL +#endif + CAMLprim value caml_int64_bswap(value v) { int64_t x = Int64_val(v); return caml_copy_int64 - (((x & 0x00000000000000FFULL) << 56) | - ((x & 0x000000000000FF00ULL) << 40) | - ((x & 0x0000000000FF0000ULL) << 24) | - ((x & 0x00000000FF000000ULL) << 8) | - ((x & 0x000000FF00000000ULL) >> 8) | - ((x & 0x0000FF0000000000ULL) >> 24) | - ((x & 0x00FF000000000000ULL) >> 40) | - ((x & 0xFF00000000000000ULL) >> 56)); + (((x & INT64_LITERAL(0x00000000000000FFU)) << 56) | + ((x & INT64_LITERAL(0x000000000000FF00U)) << 40) | + ((x & INT64_LITERAL(0x0000000000FF0000U)) << 24) | + ((x & INT64_LITERAL(0x00000000FF000000U)) << 8) | + ((x & INT64_LITERAL(0x000000FF00000000U)) >> 8) | + ((x & INT64_LITERAL(0x0000FF0000000000U)) >> 24) | + ((x & INT64_LITERAL(0x00FF000000000000U)) >> 40) | + ((x & INT64_LITERAL(0xFF00000000000000U)) >> 56)); } CAMLprim value caml_int64_of_int(value v) diff --git a/byterun/io.c b/byterun/io.c index b9f5af36..b11eeccf 100644 --- a/byterun/io.c +++ b/byterun/io.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Buffered input/output. */ #include @@ -110,7 +112,7 @@ static void unlink_channel(struct channel *channel) CAMLexport void caml_close_channel(struct channel *channel) { - close(channel->fd); + CAML_SYS_CLOSE(channel->fd); if (channel->refcount > 0) return; if (caml_channel_mutex_free != NULL) (*caml_channel_mutex_free)(channel); unlink_channel(channel); @@ -186,10 +188,10 @@ CAMLexport void caml_putword(struct channel *channel, uint32_t w) { if (! caml_channel_binary_mode(channel)) caml_failwith("output_binary_int: not a binary channel"); - putch(channel, w >> 24); - putch(channel, w >> 16); - putch(channel, w >> 8); - putch(channel, w); + caml_putch(channel, w >> 24); + caml_putch(channel, w >> 16); + caml_putch(channel, w >> 8); + caml_putch(channel, w); } CAMLexport int caml_putblock(struct channel *channel, char *p, intnat len) @@ -276,7 +278,7 @@ CAMLexport uint32_t caml_getword(struct channel *channel) caml_failwith("input_binary_int: not a binary channel"); res = 0; for(i = 0; i < 4; i++) { - res = (res << 8) + getch(channel); + res = (res << 8) + caml_getch(channel); } return res; } @@ -307,16 +309,18 @@ CAMLexport int caml_getblock(struct channel *channel, char *p, intnat len) } } -CAMLexport int caml_really_getblock(struct channel *chan, char *p, intnat n) +/* Returns the number of bytes read. */ +CAMLexport intnat caml_really_getblock(struct channel *chan, char *p, intnat n) { + intnat k = n; int r; - while (n > 0) { - r = caml_getblock(chan, p, n); + while (k > 0) { + r = caml_getblock(chan, p, k); if (r == 0) break; p += r; - n -= r; + k -= r; } - return (n == 0); + return n - k; } CAMLexport void caml_seek_in(struct channel *channel, file_offset dest) @@ -530,7 +534,7 @@ CAMLprim value caml_ml_close_channel(value vchannel) if (do_syscall) { caml_enter_blocking_section(); - result = close(fd); + result = CAML_SYS_CLOSE(fd); caml_leave_blocking_section(); } @@ -616,7 +620,7 @@ CAMLprim value caml_ml_output_char(value vchannel, value ch) struct channel * channel = Channel(vchannel); Lock(channel); - putch(channel, Long_val(ch)); + caml_putch(channel, Long_val(ch)); Unlock(channel); CAMLreturn (Val_unit); } @@ -645,7 +649,7 @@ CAMLprim value caml_ml_output_partial(value vchannel, value buff, value start, CAMLreturn (Val_int(res)); } -CAMLprim value caml_ml_output(value vchannel, value buff, value start, +CAMLprim value caml_ml_output_bytes(value vchannel, value buff, value start, value length) { CAMLparam4 (vchannel, buff, start, length); @@ -654,6 +658,8 @@ CAMLprim value caml_ml_output(value vchannel, value buff, value start, intnat len = Long_val(length); Lock(channel); + /* We cannot call caml_really_putblock here because buff may move + during caml_write_fd */ while (len > 0) { int written = caml_putblock(channel, &Byte(buff, pos), len); pos += written; @@ -663,6 +669,12 @@ CAMLprim value caml_ml_output(value vchannel, value buff, value start, CAMLreturn (Val_unit); } +CAMLprim value caml_ml_output(value vchannel, value buff, value start, + value length) +{ + return caml_ml_output_bytes (vchannel, buff, start, length); +} + CAMLprim value caml_ml_seek_out(value vchannel, value pos) { CAMLparam2 (vchannel, pos); @@ -704,7 +716,7 @@ CAMLprim value caml_ml_input_char(value vchannel) unsigned char c; Lock(channel); - c = getch(channel); + c = caml_getch(channel); Unlock(channel); CAMLreturn (Val_long(c)); } diff --git a/byterun/lexing.c b/byterun/lexing.c index 567b7a76..b1049904 100644 --- a/byterun/lexing.c +++ b/byterun/lexing.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* The table-driven automaton for lexers generated by camllex. */ #include "caml/fail.h" diff --git a/byterun/main.c b/byterun/main.c index 2a017284..e773dd9b 100644 --- a/byterun/main.c +++ b/byterun/main.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Main entry point (can be overridden by a user-provided main() function that calls caml_main() later). */ diff --git a/byterun/major_gc.c b/byterun/major_gc.c index 4e75012e..5a3e4cb1 100644 --- a/byterun/major_gc.c +++ b/byterun/major_gc.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + #include #include @@ -399,7 +401,7 @@ static void mark_slice (intnat work) if (Tag_hd (hd) < No_scan_tag){ start = size < start ? size : start; end = size < end ? size : end; - CAMLassert (end > start); + CAMLassert (end >= start); INSTR (slice_fields += end - start;) INSTR (if (size > end) CAML_INSTR_INT ("major/mark/slice/remain", size - end);) @@ -469,7 +471,7 @@ static void mark_slice (intnat work) /* Subphase_mark_main is done. Mark finalised values. */ gray_vals_cur = gray_vals_ptr; - caml_final_update (); + caml_final_update_mark_phase (); gray_vals_ptr = gray_vals_cur; if (gray_vals_ptr > gray_vals){ v = *--gray_vals_ptr; @@ -481,17 +483,18 @@ static void mark_slice (intnat work) } break; case Subphase_mark_final: { + /** The set of unreachable value will not change anymore for + this cycle. Start clean phase. */ + caml_gc_phase = Phase_clean; + caml_final_update_clean_phase (); 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. */ + /* Initialise the sweep phase. */ init_sweep_phase(); - work = 0; } + work = 0; } break; default: Assert (0); diff --git a/byterun/md5.c b/byterun/md5.c index 3d5ae496..2e128010 100644 --- a/byterun/md5.c +++ b/byterun/md5.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + #include #include "caml/alloc.h" #include "caml/fail.h" diff --git a/byterun/memory.c b/byterun/memory.c index 4b52b820..038eaa56 100644 --- a/byterun/memory.c +++ b/byterun/memory.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + #include #include #include "caml/address_class.h" @@ -284,6 +286,15 @@ char *caml_alloc_for_heap (asize_t request) } } +/* Use this function if a block allocated with [caml_alloc_for_heap] is + not actually going to be added to the heap. The caller is responsible + for freeing it. */ +void caml_disown_for_heap (char* mem) +{ + /* Currently a no-op. */ + (void)mem; /* can CAMLunused_{start,end} be used here? */ +} + /* Use this function to free a block allocated with [caml_alloc_for_heap] if you don't add it with [caml_add_to_heap]. */ @@ -392,7 +403,9 @@ static value *expand_heap (mlsize_t request) Field (Val_hp (hp), 0) = (value) NULL; }else{ Field (Val_hp (prev), 0) = (value) NULL; - if (remain == 1) Hd_hp (hp) = Make_header (0, 0, Caml_white); + if (remain == 1) { + Hd_hp (hp) = Make_header_allocated_here (0, 0, Caml_white); + } } Assert (Wosize_hp (mem) >= request); if (caml_add_to_heap ((char *) mem) != 0){ @@ -459,7 +472,7 @@ color_t caml_allocation_color (void *hp) } static inline value caml_alloc_shr_aux (mlsize_t wosize, tag_t tag, - int raise_oom) + int raise_oom, uintnat profinfo) { header_t *hp; value *new_block; @@ -490,14 +503,16 @@ static inline value caml_alloc_shr_aux (mlsize_t wosize, tag_t tag, /* Inline expansion of caml_allocation_color. */ 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); + Hd_hp (hp) = Make_header_with_profinfo (wosize, tag, Caml_black, profinfo); }else{ Assert (caml_gc_phase == Phase_idle || (caml_gc_phase == Phase_sweep && (addr)hp < (addr)caml_gc_sweep_hp)); - Hd_hp (hp) = Make_header (wosize, tag, Caml_white); + Hd_hp (hp) = Make_header_with_profinfo (wosize, tag, Caml_white, profinfo); } - Assert (Hd_hp (hp) == Make_header (wosize, tag, caml_allocation_color (hp))); + Assert (Hd_hp (hp) + == Make_header_with_profinfo (wosize, tag, caml_allocation_color (hp), + profinfo)); caml_allocated_words += Whsize_wosize (wosize); if (caml_allocated_words > caml_minor_heap_wsz){ CAML_INSTR_INT ("request_major/alloc_shr@", 1); @@ -516,13 +531,35 @@ static inline value caml_alloc_shr_aux (mlsize_t wosize, tag_t tag, CAMLexport value caml_alloc_shr_no_raise (mlsize_t wosize, tag_t tag) { - return caml_alloc_shr_aux(wosize, tag, 0); + return caml_alloc_shr_aux(wosize, tag, 0, 0); +} + +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) +#include "spacetime.h" + +CAMLexport value caml_alloc_shr_with_profinfo (mlsize_t wosize, tag_t tag, + intnat profinfo) +{ + return caml_alloc_shr_aux(wosize, tag, 1, profinfo); } +CAMLexport value caml_alloc_shr_preserving_profinfo (mlsize_t wosize, + tag_t tag, header_t old_header) +{ + return caml_alloc_shr_with_profinfo (wosize, tag, Profinfo_hd(old_header)); +} + +CAMLexport value caml_alloc_shr (mlsize_t wosize, tag_t tag) +{ + return caml_alloc_shr_with_profinfo (wosize, tag, + caml_spacetime_my_profinfo (NULL, wosize)); +} +#else CAMLexport value caml_alloc_shr (mlsize_t wosize, tag_t tag) { - return caml_alloc_shr_aux(wosize, tag, 1); + return caml_alloc_shr_aux (wosize, tag, 1, 0); } +#endif /* Dependent memory is all memory blocks allocated out of the heap that depend on the GC (and finalizers) for deallocation. diff --git a/byterun/meta.c b/byterun/meta.c index 14205f1f..9ec0358b 100644 --- a/byterun/meta.c +++ b/byterun/meta.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Primitives for the toplevel */ #include diff --git a/byterun/minor_gc.c b/byterun/minor_gc.c index 727fdb01..2596e7a5 100644 --- a/byterun/minor_gc.c +++ b/byterun/minor_gc.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + #include #include "caml/custom.h" #include "caml/config.h" @@ -37,7 +39,7 @@ this interval. [caml_young_alloc_start]...[caml_young_alloc_end] The allocation arena: newly-allocated blocks are carved from - this interval. + this interval, starting at [caml_young_alloc_end]. [caml_young_alloc_mid] is the mid-point of this interval. [caml_young_ptr], [caml_young_trigger], [caml_young_limit] These pointers are all inside the allocation arena. @@ -191,7 +193,7 @@ void caml_oldify_one (value v, value *p) value field0; sz = Wosize_hd (hd); - result = caml_alloc_shr (sz, tag); + result = caml_alloc_shr_preserving_profinfo (sz, tag, hd); *p = result; field0 = Field (v, 0); Hd_val (v) = 0; /* Set forward flag */ @@ -208,7 +210,7 @@ void caml_oldify_one (value v, value *p) } }else if (tag >= No_scan_tag){ sz = Wosize_hd (hd); - result = caml_alloc_shr (sz, tag); + result = caml_alloc_shr_preserving_profinfo (sz, tag, hd); for (i = 0; i < sz; i++) Field (result, i) = Field (v, i); Hd_val (v) = 0; /* Set forward flag */ Field (v, 0) = result; /* and forward pointer. */ @@ -237,7 +239,7 @@ void caml_oldify_one (value v, value *p) if (!vv || ft == Forward_tag || ft == Lazy_tag || ft == Double_tag){ /* Do not short-circuit the pointer. Copy as a normal block. */ Assert (Wosize_hd (hd) == 1); - result = caml_alloc_shr (1, Forward_tag); + result = caml_alloc_shr_preserving_profinfo (1, Forward_tag, hd); *p = result; Hd_val (v) = 0; /* Set (GC) forward flag */ Field (v, 0) = result; /* and forward pointer. */ @@ -365,6 +367,8 @@ void caml_empty_minor_heap (void) } } } + /* Update the OCaml finalise_last values */ + caml_final_update_minor_roots(); /* Run custom block finalisation of dead minor values */ for (elt = caml_custom_table.base; elt < caml_custom_table.ptr; elt++){ value v = elt->block; @@ -394,6 +398,7 @@ void caml_empty_minor_heap (void) ++ caml_stat_minor_collections; if (caml_minor_gc_end_hook != NULL) (*caml_minor_gc_end_hook) (); }else{ + /* The minor heap is empty nothing to do. */ caml_final_empty_young (); } #ifdef DEBUG diff --git a/byterun/misc.c b/byterun/misc.c index 9c6ded0d..447b933f 100644 --- a/byterun/misc.c +++ b/byterun/misc.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + #include #include #include @@ -105,6 +107,9 @@ char *caml_aligned_malloc (asize_t size, int modulo, void **block) return (char *) (aligned_mem - modulo); } +/* If you change the caml_ext_table* functions, also update + asmrun/spacetime.c:find_trie_node_from_libunwind. */ + void caml_ext_table_init(struct ext_table * tbl, int init_capa) { tbl->size = 0; @@ -139,11 +144,18 @@ void caml_ext_table_remove(struct ext_table * tbl, void * data) } } -void caml_ext_table_free(struct ext_table * tbl, int free_entries) +void caml_ext_table_clear(struct ext_table * tbl, int free_entries) { int i; - if (free_entries) + if (free_entries) { for (i = 0; i < tbl->size; i++) caml_stat_free(tbl->contents[i]); + } + tbl->size = 0; +} + +void caml_ext_table_free(struct ext_table * tbl, int free_entries) +{ + caml_ext_table_clear(tbl, free_entries); caml_stat_free(tbl->contents); } diff --git a/byterun/obj.c b/byterun/obj.c index 5f1efdd4..861f5c1e 100644 --- a/byterun/obj.c +++ b/byterun/obj.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Operations on objects */ #include @@ -26,6 +28,7 @@ #include "caml/misc.h" #include "caml/mlvalues.h" #include "caml/prims.h" +#include "spacetime.h" /* [size] is a value encoding a number of bytes */ CAMLprim value caml_static_alloc(value size) @@ -44,6 +47,7 @@ CAMLprim value caml_static_resize(value blk, value new_size) return (value) caml_stat_resize((char *) blk, (asize_t) Long_val(new_size)); } +/* unused since GPR#427 */ CAMLprim value caml_obj_is_block(value arg) { return Val_bool(Is_block(arg)); @@ -85,6 +89,7 @@ CAMLprim value caml_obj_block(value tag, value size) return res; } +/* Spacetime profiling assumes that this function is only called from OCaml. */ CAMLprim value caml_obj_dup(value arg) { CAMLparam1 (arg); @@ -99,7 +104,9 @@ CAMLprim value caml_obj_dup(value arg) res = caml_alloc(sz, tg); memcpy(Bp_val(res), Bp_val(arg), sz * sizeof(value)); } else if (sz <= Max_young_wosize) { - res = caml_alloc_small(sz, tg); + uintnat profinfo; + Get_my_profinfo_with_cached_backtrace(profinfo, sz); + res = caml_alloc_small_with_my_or_given_profinfo(sz, tg, profinfo); for (i = 0; i < sz; i++) Field(res, i) = Field(arg, i); } else { res = caml_alloc_shr(sz, tg); @@ -154,7 +161,8 @@ CAMLprim value caml_obj_truncate (value v, value newsize) ref_table. */ Field (v, new_wosize) = Make_header (Wosize_whsize (wosize-new_wosize), Abstract_tag, Caml_black); - Hd_val (v) = Make_header (new_wosize, tag, color); + Hd_val (v) = + Make_header_with_profinfo (new_wosize, tag, color, Profinfo_val(v)); return Val_unit; } @@ -260,3 +268,122 @@ CAMLprim value caml_fresh_oo_id (value v) { CAMLprim value caml_int_as_pointer (value n) { return n - 1; } + +/* Compute how many words in the heap are occupied by blocks accessible + from a given value */ + +#define ENTRIES_PER_QUEUE_CHUNK 4096 +struct queue_chunk { + struct queue_chunk *next; + value entries[ENTRIES_PER_QUEUE_CHUNK]; +}; + + +CAMLprim value caml_obj_reachable_words(value v) +{ + static struct queue_chunk first_chunk; + struct queue_chunk *read_chunk, *write_chunk; + int write_pos, read_pos, i; + + intnat size = 0; + header_t hd; + mlsize_t sz; + + if (Is_long(v) || !Is_in_heap_or_young(v)) return Val_int(0); + if (Tag_hd(Hd_val(v)) == Infix_tag) v -= Infix_offset_hd(Hd_val(v)); + hd = Hd_val(v); + sz = Wosize_hd(hd); + + read_chunk = write_chunk = &first_chunk; + read_pos = 0; + write_pos = 1; + write_chunk->entries[0] = v | Colornum_hd(hd); + Hd_val(v) = Bluehd_hd(hd); + + /* We maintain a queue of "interesting" blocks that have been seen. + An interesting block is a block in the heap which does not + represent an infix pointer. Infix pointers are normalized to the + beginning of their block. Blocks in the static data area are excluded. + + The function maintains a queue of block pointers. Concretely, + the queue is stored as a linked list of chunks, each chunk + holding a number of pointers to interesting blocks. Initially, + it contains only the "root" value. The first chunk of the queue + is allocated statically. More chunks can be allocated as needed + and released before this function exits. + + When a block is inserted in the queue, it is marked as blue. + This mark is used to avoid a second visit of the same block. + The real color is stored in the last 2 bits of the pointer in the + queue. (Same technique as in extern.c.) + + Note: we make the assumption that there is no pointer + from the static data area to the heap. + */ + + /* First pass: mark accessible blocks and compute their total size */ + while (read_pos != write_pos || read_chunk != write_chunk) { + /* Pop the next element from the queue */ + if (read_pos == ENTRIES_PER_QUEUE_CHUNK) { + read_pos = 0; + read_chunk = read_chunk->next; + } + v = read_chunk->entries[read_pos++] & ~3; + + hd = Hd_val(v); + sz = Wosize_hd(hd); + + size += Whsize_wosize(sz); + + if (Tag_hd(hd) < No_scan_tag) { + /* Push the interesting fields on the queue */ + for (i = 0; i < sz; i++) { + value v2 = Field(v, i); + if (Is_block(v2) && Is_in_heap_or_young(v2)) { + if (Tag_hd(Hd_val(v2)) == Infix_tag){ + v2 -= Infix_offset_hd(Hd_val(v2)); + } + hd = Hd_val(v2); + if (Color_hd(hd) != Caml_blue) { + if (write_pos == ENTRIES_PER_QUEUE_CHUNK) { + struct queue_chunk *new_chunk = + malloc(sizeof(struct queue_chunk)); + if (new_chunk == NULL) { + size = (-1); + goto release; + } + write_chunk->next = new_chunk; + write_pos = 0; + write_chunk = new_chunk; + } + write_chunk->entries[write_pos++] = v2 | Colornum_hd(hd); + Hd_val(v2) = Bluehd_hd(hd); + } + } + } + } + } + + /* Second pass: restore colors and free extra queue chunks */ + release: + read_pos = 0; + read_chunk = &first_chunk; + while (read_pos != write_pos || read_chunk != write_chunk) { + color_t colornum; + if (read_pos == ENTRIES_PER_QUEUE_CHUNK) { + struct queue_chunk *prev = read_chunk; + read_pos = 0; + read_chunk = read_chunk->next; + if (prev != &first_chunk) free(prev); + } + v = read_chunk->entries[read_pos++]; + colornum = v & 3; + v &= ~3; + Hd_val(v) = Coloredhd_hd(Hd_val(v), colornum); + } + if (read_chunk != &first_chunk) free(read_chunk); + + if (size < 0) + caml_raise_out_of_memory(); + return Val_int(size); +} diff --git a/byterun/parsing.c b/byterun/parsing.c index 89ca4c5e..ad1cc8cc 100644 --- a/byterun/parsing.c +++ b/byterun/parsing.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* The PDA automaton for parsers generated by camlyacc */ #include diff --git a/byterun/printexc.c b/byterun/printexc.c index ee7a591d..971f1724 100644 --- a/byterun/printexc.c +++ b/byterun/printexc.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Print an uncaught exception and abort */ #include @@ -141,5 +143,6 @@ void caml_fatal_uncaught_exception(value exn) else default_fatal_uncaught_exception(exn); /* Terminate the process */ - exit(2); + CAML_SYS_EXIT(2); + exit(2); /* Second exit needed for the Noreturn flag */ } diff --git a/byterun/roots.c b/byterun/roots.c index a1cba5e3..1445495a 100644 --- a/byterun/roots.c +++ b/byterun/roots.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* To walk the memory roots for garbage collection */ #include "caml/finalise.h" @@ -55,7 +57,7 @@ void caml_oldify_local_roots (void) /* Global C roots */ caml_scan_global_young_roots(&caml_oldify_one); /* Finalised values */ - caml_final_do_young_roots (&caml_oldify_one); + caml_final_oldify_young_roots (); /* Hook */ if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(&caml_oldify_one); } @@ -89,7 +91,7 @@ void caml_do_roots (scanning_action f, int do_globals) caml_scan_global_roots(f); CAML_INSTR_TIME (tmr, "major_roots/C"); /* Finalised values */ - caml_final_do_strong_roots (f); + caml_final_do_roots (f); CAML_INSTR_TIME (tmr, "major_roots/finalised"); /* Hook */ if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(f); diff --git a/byterun/signals.c b/byterun/signals.c index 5c4e2614..4763f7a9 100644 --- a/byterun/signals.c +++ b/byterun/signals.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Signal handling, code common to the bytecode and native systems */ #include @@ -29,6 +31,10 @@ #include "caml/signals_machdep.h" #include "caml/sys.h" +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) +#include "../asmrun/spacetime.h" +#endif + #ifndef NSIG #define NSIG 64 #endif @@ -133,6 +139,10 @@ static value caml_signal_handlers = 0; void caml_execute_signal(int signal_number, int in_signal_handler) { value res; + value handler; +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) + void* saved_spacetime_trie_node_ptr; +#endif #ifdef POSIX_SIGNALS sigset_t sigs; /* Block the signal before executing the handler, and record in sigs @@ -141,9 +151,36 @@ void caml_execute_signal(int signal_number, int in_signal_handler) sigaddset(&sigs, signal_number); sigprocmask(SIG_BLOCK, &sigs, &sigs); #endif - res = caml_callback_exn( - Field(caml_signal_handlers, signal_number), - Val_int(caml_rev_convert_signal_number(signal_number))); +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) + /* We record the signal handler's execution separately, in the same + trie used for finalisers. */ + saved_spacetime_trie_node_ptr + = caml_spacetime_trie_node_ptr; + caml_spacetime_trie_node_ptr + = caml_spacetime_finaliser_trie_root; +#endif +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) + /* Handled action may have no associated handler, which we interpret + as meaning the signal should be handled by a call to exit. This is + is used to allow spacetime profiles to be completed on interrupt */ + if (caml_signal_handlers == 0) { + res = caml_sys_exit(Val_int(2)); + } else { + handler = Field(caml_signal_handlers, signal_number); + if (!Is_block(handler)) { + res = caml_sys_exit(Val_int(2)); + } else { +#else + handler = Field(caml_signal_handlers, signal_number); +#endif + res = caml_callback_exn( + handler, + Val_int(caml_rev_convert_signal_number(signal_number))); +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) + } + } + caml_spacetime_trie_node_ptr = saved_spacetime_trie_node_ptr; +#endif #ifdef POSIX_SIGNALS if (! in_signal_handler) { /* Restore the original signal mask */ @@ -328,8 +365,23 @@ CAMLprim value caml_install_signal_handler(value signal_number, value action) res = Val_int(1); break; case 2: /* was Signal_handle */ + #if defined(NATIVE_CODE) && defined(WITH_SPACETIME) + /* Handled action may have no associated handler + which we treat as Signal_default */ + if (caml_signal_handlers == 0) { + res = Val_int(0); + } else { + if (!Is_block(Field(caml_signal_handlers, sig))) { + res = Val_int(0); + } else { + res = caml_alloc_small (1, 0); + Field(res, 0) = Field(caml_signal_handlers, sig); + } + } + #else res = caml_alloc_small (1, 0); Field(res, 0) = Field(caml_signal_handlers, sig); + #endif break; default: /* error in caml_set_signal_action */ caml_sys_error(NO_ARG); diff --git a/byterun/signals_byt.c b/byterun/signals_byt.c index 38aebfd0..bdbcf726 100644 --- a/byterun/signals_byt.c +++ b/byterun/signals_byt.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Signal handling, code specific to the bytecode interpreter */ #include diff --git a/byterun/spacetime.c b/byterun/spacetime.c new file mode 100644 index 00000000..fd8b4fd2 --- /dev/null +++ b/byterun/spacetime.c @@ -0,0 +1,40 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Mark Shinwell and Leo White, Jane Street Europe */ +/* */ +/* Copyright 2013--2016, Jane Street Group, LLC */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#include +#include "caml/fail.h" +#include "caml/mlvalues.h" + +int ensure_spacetime_dot_o_is_included = 42; + +CAMLprim value caml_spacetime_only_works_for_native_code(value foo, ...) +{ + caml_failwith("Spacetime profiling only works for native code"); + assert(0); /* unreachable */ +} + +uintnat caml_spacetime_my_profinfo (void) +{ + return 0; +} + +CAMLprim value caml_spacetime_enabled (value v_unit) +{ + return Val_false; /* running in bytecode */ +} + +CAMLprim value caml_register_channel_for_spacetime (value v_channel) +{ + return Val_unit; +} diff --git a/byterun/spacetime.h b/byterun/spacetime.h new file mode 100644 index 00000000..ffb006bf --- /dev/null +++ b/byterun/spacetime.h @@ -0,0 +1,21 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Mark Shinwell and Leo White, Jane Street Europe */ +/* */ +/* Copyright 2016, Jane Street Group, LLC */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#ifndef CAML_SPACETIME_H +#define CAML_SPACETIME_H + +#define Get_my_profinfo_with_cached_backtrace(profinfo, size) \ + profinfo = (uintnat) 0; + +#endif diff --git a/byterun/stacks.c b/byterun/stacks.c index cb96d2d7..5e7c9a5f 100644 --- a/byterun/stacks.c +++ b/byterun/stacks.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* To initialize and resize the stacks */ #include diff --git a/byterun/startup.c b/byterun/startup.c index 0d2c1945..ac19ee3f 100644 --- a/byterun/startup.c +++ b/byterun/startup.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Start-up code */ #include @@ -259,13 +261,15 @@ extern void caml_init_ieee_floats (void); extern void caml_signal_thread(void * lpParam); #endif -#ifdef _MSC_VER +#if defined(_MSC_VER) && __STDC_SECURE_LIB__ >= 200411L /* PR 4887: avoid crash box of windows runtime on some system calls */ extern void caml_install_invalid_parameter_handler(); #endif +extern int ensure_spacetime_dot_o_is_included; + /* Main entry point when loading code from a file */ CAMLexport void caml_main(char **argv) @@ -278,10 +282,12 @@ CAMLexport void caml_main(char **argv) char * exe_name; static char proc_self_exe[256]; + ensure_spacetime_dot_o_is_included++; + /* Machine-dependent initialization of the floating-point hardware so that it behaves as much as possible as specified in IEEE */ caml_init_ieee_floats(); -#ifdef _MSC_VER +#if defined(_MSC_VER) && __STDC_SECURE_LIB__ >= 200411L caml_install_invalid_parameter_handler(); #endif caml_init_custom_operations(); @@ -397,7 +403,7 @@ CAMLexport void caml_startup_code( static char proc_self_exe[256]; caml_init_ieee_floats(); -#ifdef _MSC_VER +#if defined(_MSC_VER) && __STDC_SECURE_LIB__ >= 200411L caml_install_invalid_parameter_handler(); #endif caml_init_custom_operations(); diff --git a/byterun/startup_aux.c b/byterun/startup_aux.c index 714e486a..109f71c3 100644 --- a/byterun/startup_aux.c +++ b/byterun/startup_aux.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Some runtime initialization functions that are common to bytecode and native code. */ @@ -28,7 +30,13 @@ CAMLexport header_t caml_atom_table[256]; void caml_init_atom_table(void) { int i; - for(i = 0; i < 256; i++) caml_atom_table[i] = Make_header(0, i, Caml_white); + for(i = 0; i < 256; i++) { +#ifdef NATIVE_CODE + caml_atom_table[i] = Make_header_allocated_here(0, i, Caml_white); +#else + caml_atom_table[i] = Make_header(0, i, Caml_white); +#endif + } if (caml_page_table_add(In_static_data, caml_atom_table, caml_atom_table + 256) != 0) { caml_fatal_error("Fatal error: not enough memory for initial page table"); diff --git a/byterun/str.c b/byterun/str.c index d8d9a74e..38a472e7 100644 --- a/byterun/str.c +++ b/byterun/str.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Operations on strings */ #include @@ -42,12 +44,20 @@ CAMLprim value caml_ml_string_length(value s) return Val_long(temp - Byte (s, temp)); } +CAMLprim value caml_ml_bytes_length(value s) +{ + return caml_ml_string_length(s); +} + CAMLexport int caml_string_is_c_safe (value s) { return strlen(String_val(s)) == caml_string_length(s); } -/* [len] is a value that represents a number of bytes (chars) */ +/** + * [caml_create_string] is deprecated, + * use [caml_create_bytes] instead + */ CAMLprim value caml_create_string(value len) { mlsize_t size = Long_val(len); @@ -57,6 +67,18 @@ CAMLprim value caml_create_string(value len) return caml_alloc_string(size); } +/* [len] is a value that represents a number of bytes (chars) */ +CAMLprim value caml_create_bytes(value len) +{ + mlsize_t size = Long_val(len); + if (size > Bsize_wsize (Max_wosize) - 1){ + caml_invalid_argument("Bytes.create"); + } + return caml_alloc_string(size); +} + + + CAMLprim value caml_string_get(value str, value index) { intnat idx = Long_val(index); @@ -64,7 +86,12 @@ CAMLprim value caml_string_get(value str, value index) return Val_int(Byte_u(str, idx)); } -CAMLprim value caml_string_set(value str, value index, value newval) +CAMLprim value caml_bytes_get(value str, value index) +{ + return caml_string_get(str, index); +} + +CAMLprim value caml_bytes_set(value str, value index, value newval) { intnat idx = Long_val(index); if (idx < 0 || idx >= caml_string_length(str)) caml_array_bound_error(); @@ -72,6 +99,16 @@ CAMLprim value caml_string_set(value str, value index, value newval) return Val_unit; } +/** + * [caml_string_set] is deprecated, + * use [caml_bytes_set] instead + */ +CAMLprim value caml_string_set(value str, value index, value newval) +{ + return caml_bytes_set(str,index,newval); +} + + CAMLprim value caml_string_get16(value str, value index) { intnat res; @@ -229,11 +266,21 @@ CAMLprim value caml_string_equal(value s1, value s2) return Val_true; } +CAMLprim value caml_bytes_equal(value s1, value s2) +{ + return caml_string_equal(s1,s2); +} + CAMLprim value caml_string_notequal(value s1, value s2) { return Val_not(caml_string_equal(s1, s2)); } +CAMLprim value caml_bytes_notequal(value s1, value s2) +{ + return caml_string_notequal(s1,s2); +} + CAMLprim value caml_string_compare(value s1, value s2) { mlsize_t len1, len2; @@ -250,39 +297,80 @@ CAMLprim value caml_string_compare(value s1, value s2) return Val_int(0); } +CAMLprim value caml_bytes_compare(value s1, value s2) +{ + return caml_string_compare(s1,s2); +} + CAMLprim value caml_string_lessthan(value s1, value s2) { return caml_string_compare(s1, s2) < Val_int(0) ? Val_true : Val_false; } +CAMLprim value caml_bytes_lessthan(value s1, value s2) +{ + return caml_string_lessthan(s1,s2); +} + + CAMLprim value caml_string_lessequal(value s1, value s2) { return caml_string_compare(s1, s2) <= Val_int(0) ? Val_true : Val_false; } +CAMLprim value caml_bytes_lessequal(value s1, value s2) +{ + return caml_string_lessequal(s1,s2); +} + + CAMLprim value caml_string_greaterthan(value s1, value s2) { return caml_string_compare(s1, s2) > Val_int(0) ? Val_true : Val_false; } +CAMLprim value caml_bytes_greaterthan(value s1, value s2) +{ + return caml_string_greaterthan(s1,s2); +} + CAMLprim value caml_string_greaterequal(value s1, value s2) { return caml_string_compare(s1, s2) >= Val_int(0) ? Val_true : Val_false; } -CAMLprim value caml_blit_string(value s1, value ofs1, value s2, value ofs2, +CAMLprim value caml_bytes_greaterequal(value s1, value s2) +{ + return caml_string_greaterequal(s1,s2); +} + +CAMLprim value caml_blit_bytes(value s1, value ofs1, value s2, value ofs2, value n) { memmove(&Byte(s2, Long_val(ofs2)), &Byte(s1, Long_val(ofs1)), Long_val(n)); return Val_unit; } -CAMLprim value caml_fill_string(value s, value offset, value len, value init) +CAMLprim value caml_blit_string(value s1, value ofs1, value s2, value ofs2, + value n) +{ + return caml_blit_bytes (s1, ofs1, s2, ofs2, n); +} + +CAMLprim value caml_fill_bytes(value s, value offset, value len, value init) { memset(&Byte(s, Long_val(offset)), Int_val(init), Long_val(len)); return Val_unit; } +/** + * [caml_fill_string] is deprecated, use [caml_fill_bytes] instead + */ +CAMLprim value caml_fill_string(value s, value offset, value len, value init) +{ + return caml_fill_bytes (s, offset, len, init); +} + CAMLprim value caml_bitvect_test(value bv, value n) { intnat pos = Long_val(n); diff --git a/byterun/sys.c b/byterun/sys.c index 0fbc382e..78ec5fe7 100644 --- a/byterun/sys.c +++ b/byterun/sys.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Basic system calls */ #include @@ -55,6 +57,7 @@ #include "caml/signals.h" #include "caml/stacks.h" #include "caml/sys.h" +#include "caml/version.h" static char * error_message(void) { @@ -108,8 +111,10 @@ static void caml_sys_check_path(value name) } } -CAMLprim value caml_sys_exit(value retcode) +CAMLprim value caml_sys_exit(value retcode_v) { + int retcode = Int_val(retcode_v); + if ((caml_verb_gc & 0x400) != 0) { /* cf caml_gc_counters */ double minwords = caml_stat_minor_words @@ -139,7 +144,7 @@ CAMLprim value caml_sys_exit(value retcode) caml_debugger(PROGRAM_EXIT); #endif CAML_INSTR_ATEXIT (); - exit(Int_val(retcode)); + CAML_SYS_EXIT(retcode); return Val_unit; } @@ -174,7 +179,7 @@ CAMLprim value caml_sys_open(value path, value vflags, value vperm) perm = Int_val(vperm); /* open on a named FIFO can block (PR#1533) */ caml_enter_blocking_section(); - fd = open(p, flags, perm); + fd = CAML_SYS_OPEN(p, flags, perm); /* fcntl on a fd can block (PR#5069)*/ #if defined(F_SETFD) && defined(FD_CLOEXEC) if (fd != -1) @@ -186,10 +191,11 @@ CAMLprim value caml_sys_open(value path, value vflags, value vperm) CAMLreturn(Val_long(fd)); } -CAMLprim value caml_sys_close(value fd) +CAMLprim value caml_sys_close(value fd_v) { + int fd = Int_val(fd_v); caml_enter_blocking_section(); - close(Int_val(fd)); + CAML_SYS_CLOSE(fd); caml_leave_blocking_section(); return Val_unit; } @@ -210,7 +216,7 @@ CAMLprim value caml_sys_file_exists(value name) #ifdef _WIN32 ret = _stati64(p, &st); #else - ret = stat(p, &st); + ret = CAML_SYS_STAT(p, &st); #endif caml_leave_blocking_section(); caml_stat_free(p); @@ -235,7 +241,7 @@ CAMLprim value caml_sys_is_directory(value name) #ifdef _WIN32 ret = _stati64(p, &st); #else - ret = stat(p, &st); + ret = CAML_SYS_STAT(p, &st); #endif caml_leave_blocking_section(); caml_stat_free(p); @@ -256,7 +262,7 @@ CAMLprim value caml_sys_remove(value name) caml_sys_check_path(name); p = caml_strdup(String_val(name)); caml_enter_blocking_section(); - ret = unlink(p); + ret = CAML_SYS_UNLINK(p); caml_leave_blocking_section(); caml_stat_free(p); if (ret != 0) caml_sys_error(name); @@ -273,7 +279,7 @@ CAMLprim value caml_sys_rename(value oldname, value newname) p_old = caml_strdup(String_val(oldname)); p_new = caml_strdup(String_val(newname)); caml_enter_blocking_section(); - ret = rename(p_old, p_new); + ret = CAML_SYS_RENAME(p_old, p_new); caml_leave_blocking_section(); caml_stat_free(p_new); caml_stat_free(p_old); @@ -290,7 +296,7 @@ CAMLprim value caml_sys_chdir(value dirname) caml_sys_check_path(dirname); p = caml_strdup(String_val(dirname)); caml_enter_blocking_section(); - ret = chdir(p); + ret = CAML_SYS_CHDIR(p); caml_leave_blocking_section(); caml_stat_free(p); if (ret != 0) caml_sys_error(dirname); @@ -313,7 +319,7 @@ CAMLprim value caml_sys_getenv(value var) char * res; if (! caml_string_is_c_safe(var)) caml_raise_not_found(); - res = getenv(String_val(var)); + res = CAML_SYS_GETENV(String_val(var)); if (res == 0) caml_raise_not_found(); return caml_copy_string(res); } @@ -335,6 +341,9 @@ CAMLprim value caml_sys_get_argv(value unit) void caml_sys_init(char * exe_name, char **argv) { +#ifdef CAML_WITH_CPLUGINS + caml_cplugins_init(exe_name, argv); +#endif caml_exe_name = exe_name; caml_main_argv = argv; } @@ -362,7 +371,7 @@ CAMLprim value caml_sys_system_command(value command) } buf = caml_strdup(String_val(command)); caml_enter_blocking_section (); - status = system(buf); + status = CAML_SYS_SYSTEM(buf); caml_leave_blocking_section (); caml_stat_free(buf); if (status == -1) caml_sys_error(command); @@ -493,6 +502,10 @@ CAMLprim value caml_sys_const_ostype_cygwin(value unit) return Val_bool(0 == strcmp(OCAML_OS_TYPE,"Cygwin")); } +CAMLprim value caml_sys_const_backend_type(value unit) +{ + return Val_int(1); /* Bytecode backed */ +} CAMLprim value caml_sys_get_config(value unit) { CAMLparam0 (); /* unit is unused */ @@ -522,7 +535,7 @@ CAMLprim value caml_sys_read_directory(value path) caml_ext_table_init(&tbl, 50); p = caml_strdup(String_val(path)); caml_enter_blocking_section(); - ret = caml_read_directory(p, &tbl); + ret = CAML_SYS_READ_DIRECTORY(p, &tbl); caml_leave_blocking_section(); caml_stat_free(p); if (ret == -1){ @@ -552,3 +565,73 @@ CAMLprim value caml_sys_isatty(value chan) return ret; } + +/* Load dynamic plugins indicated in the CAML_CPLUGINS environment + variable. These plugins can be used to set currently existing + hooks, such as GC hooks and system calls tracing (see misc.h). + */ + +#ifdef CAML_WITH_CPLUGINS + +value (*caml_cplugins_prim)(int,value,value,value) = NULL; + +#define DLL_EXECUTABLE 1 +#define DLL_NOT_GLOBAL 0 + +static struct cplugin_context cplugin_context; + +void caml_load_plugin(char *plugin) +{ + void* dll_handle = NULL; + + dll_handle = caml_dlopen(plugin, DLL_EXECUTABLE, DLL_NOT_GLOBAL); + if( dll_handle != NULL ){ + void (* dll_init)(struct cplugin_context*) = + caml_dlsym(dll_handle, "caml_cplugin_init"); + if( dll_init != NULL ){ + cplugin_context.plugin=plugin; + dll_init(&cplugin_context); + } else { + caml_dlclose(dll_handle); + } + } else { + fprintf(stderr, "Cannot load C plugin %s\nReason: %s\n", + plugin, caml_dlerror()); + } +} + +void caml_cplugins_load(char *env_variable) +{ + char *plugins = getenv(env_variable); + if(plugins != NULL){ + char* curs = plugins; + while(*curs != 0){ + if(*curs == ','){ + if(curs > plugins){ + *curs = 0; + caml_load_plugin(plugins); + } + plugins = curs+1; + } + curs++; + } + if(curs > plugins) caml_load_plugin(plugins); + } +} + +void caml_cplugins_init(char * exe_name, char **argv) +{ + cplugin_context.api_version = CAML_CPLUGIN_CONTEXT_API; + cplugin_context.prims_bitmap = CAML_CPLUGINS_PRIMS_BITMAP; + cplugin_context.exe_name = exe_name; + cplugin_context.argv = argv; + cplugin_context.ocaml_version = OCAML_VERSION_STRING; + caml_cplugins_load("CAML_CPLUGINS"); +#ifdef NATIVE_CODE + caml_cplugins_load("CAML_NATIVE_CPLUGINS"); +#else + caml_cplugins_load("CAML_BYTE_CPLUGINS"); +#endif +} + +#endif /* CAML_WITH_CPLUGINS */ diff --git a/byterun/terminfo.c b/byterun/terminfo.c index 41257328..05ec87d3 100644 --- a/byterun/terminfo.c +++ b/byterun/terminfo.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Read and output terminal commands */ #include "caml/config.h" @@ -74,7 +76,7 @@ CAMLprim value caml_terminfo_setup (value vchan) static int terminfo_putc (int c) { - putch (chan, c); + caml_putch (chan, c); return c; } diff --git a/byterun/unix.c b/byterun/unix.c index d3627733..150af2b2 100644 --- a/byterun/unix.c +++ b/byterun/unix.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Unix-specific stuff */ #define _GNU_SOURCE @@ -47,6 +49,7 @@ #include "caml/osdeps.h" #include "caml/signals.h" #include "caml/sys.h" +#include "caml/io.h" #ifndef S_ISREG #define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG) @@ -78,9 +81,17 @@ int caml_write_fd(int fd, int flags, void * buf, int n) { int retcode; again: +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) + if (flags & CHANNEL_FLAG_BLOCKING_WRITE) { + retcode = write(fd, buf, n); + } else { +#endif caml_enter_blocking_section(); retcode = write(fd, buf, n); caml_leave_blocking_section(); +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) + } +#endif if (retcode == -1) { if (errno == EINTR) goto again; if ((errno == EAGAIN || errno == EWOULDBLOCK) && n > 1) { @@ -322,7 +333,7 @@ char * caml_dlerror(void) the directory named [dirname]. No entries are added for [.] and [..]. Return 0 on success, -1 on error; set errno in the case of error. */ -int caml_read_directory(char * dirname, struct ext_table * contents) +CAMLexport int caml_read_directory(char * dirname, struct ext_table * contents) { DIR * d; #ifdef HAS_DIRENT diff --git a/byterun/weak.c b/byterun/weak.c index 39806ced..308d153c 100644 --- a/byterun/weak.c +++ b/byterun/weak.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Operations on weak arrays and ephemerons (named ephe here)*/ #include diff --git a/byterun/win32.c b/byterun/win32.c index c7865e66..59d13000 100644 --- a/byterun/win32.c +++ b/byterun/win32.c @@ -13,6 +13,8 @@ /* */ /**************************************************************************/ +#define CAML_INTERNALS + /* Win32-specific stuff */ #define WIN32_LEAN_AND_MEAN @@ -49,6 +51,12 @@ #define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG) #endif +/* Very old Microsoft headers don't include intptr_t */ +#if defined(_MSC_VER) && !defined(_UINTPTR_T_DEFINED) +typedef unsigned int uintptr_t; +#define _UINTPTR_T_DEFINED +#endif + CAMLnoreturn_start static void caml_win32_sys_error (int errnum) CAMLnoreturn_end; @@ -97,9 +105,17 @@ int caml_write_fd(int fd, int flags, void * buf, int n) { int retcode; if ((flags & CHANNEL_FLAG_FROM_SOCKET) == 0) { +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) + if (flags & CHANNEL_FLAG_BLOCKING_WRITE) { + retcode = write(fd, buf, n); + } else { +#endif caml_enter_blocking_section(); retcode = write(fd, buf, n); caml_leave_blocking_section(); +#if defined(NATIVE_CODE) && defined(WITH_SPACETIME) + } +#endif if (retcode == -1) caml_sys_io_error(NO_ARG); } else { caml_enter_blocking_section(); @@ -579,7 +595,7 @@ int caml_win32_random_seed (intnat data[16]) } -#ifdef _MSC_VER +#if defined(_MSC_VER) && __STDC_SECURE_LIB__ >= 200411L static void invalid_parameter_handler(const wchar_t* expression, const wchar_t* function, @@ -612,6 +628,26 @@ int caml_executable_name(char * name, int name_len) /* snprintf emulation */ +#ifdef LACKS_VSCPRINTF +/* No _vscprintf until Visual Studio .NET 2002 and sadly no version number + in the CRT headers until Visual Studio 2005 so forced to predicate this + on the compiler version instead */ +int _vscprintf(const char * format, va_list args) +{ + int n; + int sz = 5; + char* buf = (char*)malloc(sz); + n = _vsnprintf(buf, sz, format, args); + while (n < 0 || n > sz) { + sz += 512; + buf = (char*)realloc(buf, sz); + n = _vsnprintf(buf, sz, format, args); + } + free(buf); + return n; +} +#endif + #if defined(_WIN32) && !defined(_UCRT) int caml_snprintf(char * buf, size_t size, const char * format, ...) { diff --git a/config/Makefile-templ b/config/Makefile-templ index 6b8231eb..1cd797eb 100644 --- a/config/Makefile-templ +++ b/config/Makefile-templ @@ -33,9 +33,9 @@ MANEXT=1 ### Do #! scripts work on your system? ### Beware: on some systems (e.g. SunOS 4), this will work only if ### the string "#!$(BINDIR)/ocamlrun" is less than 32 characters long. -### In doubt, set SHARPBANGSCRIPTS to false. -SHARPBANGSCRIPTS=true -#SHARPBANGSCRIPTS=false +### In doubt, set HASHBANGSCRIPTS to false. +HASHBANGSCRIPTS=true +#HASHBANGSCRIPTS=false ########## Configuration for the bytecode compiler diff --git a/config/Makefile.mingw b/config/Makefile.mingw index 527e9915..f2d04116 100644 --- a/config/Makefile.mingw +++ b/config/Makefile.mingw @@ -61,7 +61,7 @@ EXT_OBJ=.$(O) EXT_LIB=.$(A) EXT_ASM=.$(S) MANEXT=1 -SHARPBANGSCRIPTS=false +HASHBANGSCRIPTS=false PTHREAD_LINK= X11_INCLUDES= X11_LINK= @@ -86,6 +86,11 @@ ASM_CFI_SUPPORTED=false UNIXLIB=win32unix GRAPHLIB=win32graph FLAMBDA=false +WITH_SPACETIME=false +LIBUNWIND_AVAILABLE=false +LIBUNWIND_LINK_FLAGS= +PROFINFO_WIDTH=26 +SAFE_STRING=false ########## Configuration for the bytecode compiler @@ -95,6 +100,12 @@ BYTECC=$(TOOLPREF)gcc ### Additional compile-time options for $(BYTECC). (For static linking.) BYTECCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused +### Additional compile-time options for $(BYTECC). (For debug version.) +BYTECCDBGCOMPOPTS=-g + +### Flag to use to rename object files. (for debug version.) +NAME_OBJ_FLAG=-o + ### Additional link-time options for $(BYTECC). (For static linking.) BYTECCLINKOPTS= diff --git a/config/Makefile.mingw64 b/config/Makefile.mingw64 index 79ff7943..14c575b3 100644 --- a/config/Makefile.mingw64 +++ b/config/Makefile.mingw64 @@ -61,7 +61,7 @@ EXT_OBJ=.$(O) EXT_LIB=.$(A) EXT_ASM=.$(S) MANEXT=1 -SHARPBANGSCRIPTS=false +HASHBANGSCRIPTS=false PTHREAD_LINK= X11_INCLUDES= X11_LINK= @@ -86,6 +86,11 @@ ASM_CFI_SUPPORTED=false UNIXLIB=win32unix GRAPHLIB=win32graph FLAMBDA=false +WITH_SPACETIME=false +LIBUNWIND_AVAILABLE=false +LIBUNWIND_LINK_FLAGS= +PROFINFO_WIDTH=26 +SAFE_STRING=false ########## Configuration for the bytecode compiler @@ -95,6 +100,12 @@ BYTECC=$(TOOLPREF)gcc ### Additional compile-time options for $(BYTECC). (For static linking.) BYTECCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused +### Additional compile-time options for $(BYTECC). (For debug version.) +BYTECCDBGCOMPOPTS=-g + +### Flag to use to rename object files. (for debug version.) +NAME_OBJ_FLAG=-o + ### Additional link-time options for $(BYTECC). (For static linking.) BYTECCLINKOPTS= diff --git a/config/Makefile.msvc b/config/Makefile.msvc index 20ddaf95..5ffd6c0e 100644 --- a/config/Makefile.msvc +++ b/config/Makefile.msvc @@ -56,7 +56,7 @@ EXT_OBJ=.$(O) EXT_LIB=.$(A) EXT_ASM=.$(S) MANEXT=1 -SHARPBANGSCRIPTS=false +HASHBANGSCRIPTS=false PTHREAD_LINK= X11_INCLUDES= X11_LINK= @@ -80,6 +80,11 @@ ASM_CFI_SUPPORTED=false UNIXLIB=win32unix GRAPHLIB=win32graph FLAMBDA=false +WITH_SPACETIME=false +LIBUNWIND_AVAILABLE=false +LIBUNWIND_LINK_FLAGS= +PROFINFO_WIDTH=26 +SAFE_STRING=false ########## Configuration for the bytecode compiler @@ -89,6 +94,12 @@ BYTECC=cl -nologo -D_CRT_SECURE_NO_DEPRECATE ### Additional compile-time options for $(BYTECC). (For static linking.) BYTECCCOMPOPTS=-O2 -Gy- -MD +### Additional compile-time options for $(BYTECC). (For debug version.) +BYTECCDBGCOMPOPTS=-Zi + +### Flag to use to rename object files. (for debug version.) +NAME_OBJ_FLAG=-Fo + ### Additional link-time options for $(BYTECC). (For static linking.) BYTECCLINKOPTS= diff --git a/config/Makefile.msvc64 b/config/Makefile.msvc64 index 0758aa7c..720b2e14 100644 --- a/config/Makefile.msvc64 +++ b/config/Makefile.msvc64 @@ -56,7 +56,7 @@ EXT_OBJ=.$(O) EXT_LIB=.$(A) EXT_ASM=.$(S) MANEXT=1 -SHARPBANGSCRIPTS=false +HASHBANGSCRIPTS=false PTHREAD_LINK= X11_INCLUDES= X11_LINK= @@ -79,6 +79,11 @@ ASM_CFI_SUPPORTED=false UNIXLIB=win32unix GRAPHLIB=win32graph FLAMBDA=false +WITH_SPACETIME=false +LIBUNWIND_AVAILABLE=false +LIBUNWIND_LINK_FLAGS= +PROFINFO_WIDTH=26 +SAFE_STRING=false ########## Configuration for the bytecode compiler @@ -89,7 +94,10 @@ BYTECC=cl -nologo -D_CRT_SECURE_NO_DEPRECATE BYTECCCOMPOPTS=-O2 -Gy- -MD ### Additional compile-time options for $(BYTECC). (For debug version.) -BYTECCDBGCOMPOPTS=-DDEBUG -Zi -W3 -Wp64 +BYTECCDBGCOMPOPTS=-Zi + +### Flag to use to rename object files. (for debug version.) +NAME_OBJ_FLAG=-Fo ### Additional link-time options for $(BYTECC). (For static linking.) BYTECCLINKOPTS= diff --git a/config/auto-aux/hasgot b/config/auto-aux/hasgot index 1ba464ca..8b6c6903 100755 --- a/config/auto-aux/hasgot +++ b/config/auto-aux/hasgot @@ -24,6 +24,7 @@ while : ; do case "$1" in -i) echo "#include <$2>" >> hasgot.c; shift;; -t) echo "$2 $var;" >> hasgot.c; var="x$var"; shift;; + -Xl) libs="$libs $2"; shift;; -l*|-L*|-F*) libs="$libs $1";; -framework) libs="$libs $1 $2"; shift;; -*) opts="$opts $1";; diff --git a/config/auto-aux/hashbang b/config/auto-aux/hashbang new file mode 100755 index 00000000..eb447baa --- /dev/null +++ b/config/auto-aux/hashbang @@ -0,0 +1,2 @@ +#! /bin/cat +exit 1 diff --git a/config/auto-aux/hashbang2 b/config/auto-aux/hashbang2 new file mode 100755 index 00000000..37530963 --- /dev/null +++ b/config/auto-aux/hashbang2 @@ -0,0 +1,2 @@ +#! /usr/bin/cat +exit 1 diff --git a/config/auto-aux/sharpbang b/config/auto-aux/sharpbang deleted file mode 100755 index eb447baa..00000000 --- a/config/auto-aux/sharpbang +++ /dev/null @@ -1,2 +0,0 @@ -#! /bin/cat -exit 1 diff --git a/config/auto-aux/sharpbang2 b/config/auto-aux/sharpbang2 deleted file mode 100755 index 37530963..00000000 --- a/config/auto-aux/sharpbang2 +++ /dev/null @@ -1,2 +0,0 @@ -#! /usr/bin/cat -exit 1 diff --git a/config/m-nt.h b/config/m-nt.h index 900e3f09..28a1815a 100644 --- a/config/m-nt.h +++ b/config/m-nt.h @@ -47,3 +47,5 @@ #endif #undef NONSTANDARD_DIV_MOD + +#define PROFINFO_WIDTH 26 diff --git a/config/s-nt.h b/config/s-nt.h index 79a716f2..8c28dc5e 100644 --- a/config/s-nt.h +++ b/config/s-nt.h @@ -34,3 +34,7 @@ #define HAS_IPV6 #define HAS_NICE #define SUPPORT_DYNAMIC_LINKING +#if defined(_MSC_VER) && _MSC_VER < 1300 +#define LACKS_SANE_NAN +#define LACKS_VSCPRINTF +#endif diff --git a/config/s-templ.h b/config/s-templ.h index 567f10b1..9ab980b2 100644 --- a/config/s-templ.h +++ b/config/s-templ.h @@ -130,6 +130,9 @@ /* Define HAS_SYS_SELECT_H if /usr/include/sys/select.h exists and should be included before using select(). */ +#define HAS_NANOSLEEP +/* Define HAS_NANOSLEEP if you have nanosleep(). */ + #define HAS_SYMLINK /* Define HAS_SYMLINK if you have symlink() and readlink() and lstat(). */ diff --git a/configure b/configure index 0bb2d35f..f43893a4 100755 --- a/configure +++ b/configure @@ -36,6 +36,10 @@ mathlib='-lm' dllib='' x11_include_dir='' x11_lib_dir='' +libunwind_include_dir='' +libunwind_lib_dir='' +libunwind_available=false +disable_libunwind=false graph_wanted=yes pthread_wanted=yes dl_defs='' @@ -48,12 +52,16 @@ partialld="ld -r" with_debugger=ocamldebugger with_ocamldoc=ocamldoc with_frame_pointers=false +with_spacetime=false no_naked_pointers=false native_compiler=true TOOLPREF="" with_cfi=true flambda=false +safe_string=false max_testsuite_dir_retries=0 +with_cplugins=true +with_fpic=false # Try to turn internationalization off, can cause config.guess to malfunction! unset LANG @@ -114,6 +122,16 @@ while : ; do manext=1;; esac shift;; + -libunwinddir|--libunwinddir) + libunwind_include_dir=$2/include; + libunwind_lib_dir=$2/lib; + shift;; + -libunwindlib|--libunwindlib) + libunwind_lib_dir=$2; shift;; + -libunwindinclude|--libunwindinclude) + libunwind_include_dir=$2; shift;; + -disable-libunwind|--disable-libunwind) + disable_libunwind=true;; -host*|--host*) host_type=$2; shift;; -target*|--target*) @@ -161,12 +179,20 @@ while : ; do with_frame_pointers=true;; -no-naked-pointers|--no-naked-pointers) no_naked_pointers=true;; + -spacetime|--spacetime) + with_spacetime=true;; -no-cfi|--no-cfi) with_cfi=false;; - -no-native-compiler) + -no-native-compiler|--no-native-compiler) native_compiler=false;; - -flambda) + -flambda|--flambda) flambda=true;; + -no-cplugins|--no-cplugins) + with_cplugins=false;; + -fPIC|--fPIC) + with_fpic=true;; + -safe-string|--safe-string) + safe_string=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 '=')." @@ -211,6 +237,7 @@ touch s.h m.h Makefile # Write options to Makefile echo "# generated by ./configure $configure_options" >> Makefile +echo "CONFIGURE_ARGS=$configure_options" >> Makefile # Where to install @@ -671,7 +698,7 @@ if test $with_sharedlibs = "yes"; then mkmaindll="$flexlink -maindll" shared_libraries_supported=true;; *-*-linux-gnu|*-*-linux|*-*-freebsd[3-9]*|*-*-freebsd[1-9][0-9]*\ - |*-*-openbsd*|*-*-netbsd*|*-*-gnu*|*-*-haiku*) + |*-*-openbsd*|*-*-netbsd*|*-*-dragonfly*|*-*-gnu*|*-*-haiku*) sharedcccompopts="-fPIC" mksharedlib="$bytecc -shared" bytecclinkopts="$bytecclinkopts -Wl,-E" @@ -779,6 +806,7 @@ if test $with_sharedlibs = "yes"; then sparc*-*-linux*) natdynlink=true;; i686-*-kfreebsd*) natdynlink=true;; x86_64-*-kfreebsd*) natdynlink=true;; + x86_64-*-dragonfly*) natdynlink=true;; i[3456]86-*-freebsd*) natdynlink=true;; x86_64-*-freebsd*) natdynlink=true;; i[3456]86-*-openbsd*) natdynlink=true;; @@ -852,6 +880,7 @@ case "$target" in zaurus*-*-openbsd*) arch=arm; system=bsd;; x86_64-*-linux*) arch=amd64; system=linux;; x86_64-*-gnu*) arch=amd64; system=gnu;; + x86_64-*-dragonfly*) arch=amd64; system=dragonfly;; x86_64-*-freebsd*) arch=amd64; system=freebsd;; x86_64-*-netbsd*) arch=amd64; system=netbsd;; x86_64-*-openbsd*) arch=amd64; system=openbsd;; @@ -913,7 +942,7 @@ case "$arch,$system" in amd64,solaris) as="${TOOLPREF}as --64" aspp="${TOOLPREF}gcc -m64 -c";; i386,solaris) as="${TOOLPREF}as" - aspp="/usr/ccs/bin/${TOOLPREF}as -P";; + aspp="${TOOLPREF}gcc -c";; power,elf) if $arch64; then as="${TOOLPREF}as -a64 -mppc64" aspp="${TOOLPREF}gcc -m64 -c" @@ -930,6 +959,8 @@ case "$arch,$system" in esac;; arm,freebsd) as="${TOOLPREF}cc -c" aspp="${TOOLPREF}cc -c";; + *,dragonfly) as="${TOOLPREF}as" + aspp="${TOOLPREF}cc -c";; *,freebsd) as="${TOOLPREF}as" aspp="${TOOLPREF}cc -c";; amd64,*|arm,*|arm64,*|i386,*|power,bsd*|sparc,*) @@ -985,27 +1016,27 @@ echo "#define OCAML_STDLIB_DIR \"$libdir\"" >> s.h # Do #! scripts work? -if (SHELL=/bin/sh; export SHELL; (./sharpbang || ./sharpbang2) >/dev/null); then +if (SHELL=/bin/sh; export SHELL; (./hashbang || ./hashbang2) >/dev/null); then inf "#! appears to work in shell scripts." case "$target" in *-*-sunos*|*-*-unicos*) wrn "We won't use it, though, because under SunOS and Unicos it breaks " \ "on pathnames longer than 30 characters" - echo "SHARPBANGSCRIPTS=false" >> Makefile;; + echo "HASHBANGSCRIPTS=false" >> Makefile;; *-*-cygwin*) wrn "We won't use it, though, because of conflicts with .exe extension " \ "under Cygwin" - echo "SHARPBANGSCRIPTS=false" >> Makefile;; + echo "HASHBANGSCRIPTS=false" >> Makefile;; *-*-mingw*) inf "We won't use it, though, because it's on the target platform " \ "it would be used and windows doesn't support it." - echo "SHARPBANGSCRIPTS=false" >> Makefile;; + echo "HASHBANGSCRIPTS=false" >> Makefile;; *) - echo "SHARPBANGSCRIPTS=true" >> Makefile;; + echo "HASHBANGSCRIPTS=true" >> Makefile;; esac else inf "No support for #! in shell scripts" - echo "SHARPBANGSCRIPTS=false" >> Makefile + echo "HASHBANGSCRIPTS=false" >> Makefile fi # Use 64-bit file offset if possible @@ -1094,6 +1125,17 @@ echo "GRAPHLIB=$graphlib" >> Makefile otherlibraries="$unixlib str num dynlink bigarray" +# Spacetime profiling is only available for native code on 64-bit targets. + +case "$native_compiler" in + true) + if $arch64; then + otherlibraries="$otherlibraries raw_spacetime_lib" + fi + ;; + *) ;; +esac + # For the Unix library has_sockets=no @@ -1230,6 +1272,11 @@ if sh ./hasgot select && \ has_select=yes fi +if sh ./hasgot nanosleep ; then + inf "nanosleep() found." + echo "#define HAS_NANOSLEEP" >> s.h +fi + if sh ./hasgot symlink readlink lstat; then inf "symlink() found." echo "#define HAS_SYMLINK" >> s.h @@ -1445,6 +1492,8 @@ if test "$pthread_wanted" = "yes"; then case "$target" in *-*-solaris*) pthread_link="-lpthread -lposix4" pthread_caml_link="-cclib -lpthread -cclib -lposix4";; + *-*-dragon*) pthread_link="-pthread" + pthread_caml_link="-cclib -pthread";; *-*-freebsd*) pthread_link="-pthread" pthread_caml_link="-cclib -pthread";; *-*-openbsd*) pthread_link="-pthread" @@ -1461,7 +1510,7 @@ if test "$pthread_wanted" = "yes"; then bytecccompopts="$bytecccompopts -D_REENTRANT" nativecccompopts="$nativecccompopts -D_REENTRANT" case "$target" in - *-*-freebsd*) + *-*-freebsd*|*-*-dragonfly*) bytecccompopts="$bytecccompopts -D_THREAD_SAFE" nativecccompopts="$nativecccompopts -D_THREAD_SAFE";; *-*-openbsd*) @@ -1631,6 +1680,7 @@ if test "$x11_include" = "not found"; then else x11_libs="-L$dir" case "$target" in + *-*-freebsd*|*-*-dragonfly*) x11_link="-L$dir -lX11";; *-kfreebsd*-gnu) x11_link="-L$dir -lX11";; *-*-*bsd*) x11_link="-R$dir -L$dir -lX11";; *) x11_link="-L$dir -lX11";; @@ -1737,6 +1787,120 @@ else has_huge_pages=false fi +# Spacetime profiling, including libunwind detection + +# The number of bits used for profiling information is configurable here. +# The more bits used for profiling, the smaller will be Max_wosize. +# Note that PROFINFO_WIDTH must still be defined even if not configuring +# for Spacetime (see comment in byterun/caml/mlvalues.h on [Profinfo_hd]). +profinfo_width=26 +echo "#define PROFINFO_WIDTH $profinfo_width" >> m.h +if $with_spacetime; then + case "$arch,$system" in + amd64,*) + spacetime_supported=true + ;; + *) + spacetime_supported=false + ;; + esac + libunwind_warning=false + if $spacetime_supported; then + echo "Spacetime profiling will be available." + echo "#define WITH_SPACETIME" >> m.h + if $disable_libunwind; then + has_libunwind=no + libunwind_available=false + echo "libunwind support for Spacetime profiling was explicitly disabled." + else + # On Mac OS X, we always use the system libunwind. + if test "$libunwind_lib_dir" != ""; then + case "$arch,$system" in + amd64,macosx) + inf "[WARNING] -libunwind* options are ignored on Mac OS X" + libunwind_warning=true + libunwind_lib="-framework System" + libunwind_lib_temp="$libunwind_lib" + # We need unwinding information at runtime, but since we use + # -no_compact_unwind, we also need -keep_dwarf_unwind otherwise + # the OS X linker will chuck away the DWARF-like (.eh_frame) + # information. (Older versions of OS X don't provide this.) + mkexe="$mkexe -Wl,-keep_dwarf_unwind" + mksharedlib="$mksharedlib -Wl,-keep_dwarf_unwind" + ;; + *) + libunwind_lib="-L$libunwind_lib_dir -lunwind -lunwind-x86_64" + libunwind_lib_temp="-Xl $libunwind_lib" + ;; + esac + else + case "$arch,$system" in + amd64,macosx) + libunwind_lib="-framework System" + libunwind_lib_temp="$libunwind_lib" + mkexe="$mkexe -Wl,-keep_dwarf_unwind" + mksharedlib="$mksharedlib -Wl,-keep_dwarf_unwind" + ;; + *) + libunwind_lib="-lunwind -lunwind-x86_64" + libunwind_lib_temp="$libunwind_lib" + ;; + esac + fi + if test "$libunwind_include_dir" != ""; then + case "$arch,$system" in + amd64,macosx) + if ! $libunwind_warning; then + inf "[WARNING] -libunwind* options are ignored on Mac OS X" + fi + libunwind_include="" + ;; + *) + libunwind_include="-I$libunwind_include_dir" + ;; + esac + else + libunwind_include="" + fi + if sh ./hasgot -i libunwind.h $libunwind_lib_temp $libunwind_include; \ + then + echo "#define HAS_LIBUNWIND" >> s.h + has_libunwind=yes + libunwind_available=true + echo "libunwind support for Spacetime profiling will be available." + else + has_libunwind=no + libunwind_available=false + echo "libunwind support for Spacetime profiling will not be available." + fi + fi + else + echo "Spacetime profiling is not available on 32-bit platforms." + with_spacetime=false + libunwind_available=false + has_libunwind=no + fi +fi + +if ! $shared_libraries_supported; then + with_cplugins=false +fi + +if $with_fpic; then + bytecccompopts="$bytecccompopts $sharedcccompopts" + nativecccompopts="$nativecccompopts $sharedcccompopts" + aspp="$aspp $sharedcccompopts" +fi + + +if $with_cplugins; then + echo "#define CAML_WITH_CPLUGINS" >> m.h +fi + +if $with_fpic; then + echo "#define CAML_WITH_FPIC" >> m.h +fi + # Finish generated files cclibs="$cclibs $mathlib" @@ -1811,12 +1975,20 @@ echo "WITH_DEBUGGER=${with_debugger}" >>Makefile echo "WITH_OCAMLDOC=${with_ocamldoc}" >>Makefile echo "ASM_CFI_SUPPORTED=$asm_cfi_supported" >> Makefile echo "WITH_FRAME_POINTERS=$with_frame_pointers" >> Makefile +echo "WITH_SPACETIME=$with_spacetime" >> Makefile +echo "LIBUNWIND_AVAILABLE=$libunwind_available" >> Makefile +echo "LIBUNWIND_INCLUDE_FLAGS=$libunwind_include" >> Makefile +echo "LIBUNWIND_LINK_FLAGS=$libunwind_lib" >> Makefile +echo "PROFINFO_WIDTH=$profinfo_width" >> Makefile +echo "WITH_CPLUGINS=$with_cplugins" >> Makefile +echo "WITH_FPIC=$with_fpic" >> Makefile echo "TARGET=$target" >> Makefile echo "HOST=$host" >> Makefile if [ "$ostype" = Cygwin ]; then echo "DIFF=diff -q --strip-trailing-cr" >>Makefile fi echo "FLAMBDA=$flambda" >> Makefile +echo "SAFE_STRING=$safe_string" >> Makefile echo "MAX_TESTSUITE_DIR_RETRIES=$max_testsuite_dir_retries" >> Makefile @@ -1880,6 +2052,38 @@ else else inf " naked pointers forbidden.. no" fi + if $with_spacetime; then + inf " spacetime profiling....... yes" + inf " ... with libunwind...... $has_libunwind" + else + inf " spacetime profiling....... no" + fi + case "$arch,$system" in + amd64,macosx) + ;; + amd64,*) + if test "$has_libunwind" = "yes"; then + if test "$libunwind_include_dir" != ""; then + inf " libunwind include dir..... $libunwind_include_dir" + fi + if test "$libunwind_lib_dir" != ""; then + inf " libunwind library dir..... $libunwind_lib_dir" + fi + fi + ;; + *) + ;; + esac + if $with_cplugins; then + inf " C plugins................. yes" + else + inf " C plugins................. no" + fi + if $with_fpic; then + inf " compile with -fPIC........ yes" + else + inf " compile with -fPIC........ no" + fi inf " native dynlink ........... $natdynlink" if test "$profiling" = "prof"; then inf " profiling with gprof ..... supported" @@ -1891,6 +2095,11 @@ else else inf " using flambda middle-end . no" fi + if test "$safe_string" = "true"; then + inf " safe strings ............. yes" + else + inf " safe strings ............. no" + fi fi if test "$with_debugger" = "ocamldebugger"; then diff --git a/debugger/.depend b/debugger/.depend index b6254161..ed8ab4bf 100644 --- a/debugger/.depend +++ b/debugger/.depend @@ -1,46 +1,11 @@ -breakpoints.cmi : primitives.cmi ../bytecomp/instruct.cmi -checkpoints.cmi : primitives.cmi debugcom.cmi -command_line.cmi : -debugcom.cmi : primitives.cmi -debugger_config.cmi : -dynlink.cmi : -eval.cmi : ../typing/types.cmi ../typing/path.cmi parser_aux.cmi \ - ../parsing/longident.cmi ../bytecomp/instruct.cmi ../typing/ident.cmi \ - ../typing/env.cmi debugcom.cmi -events.cmi : ../bytecomp/instruct.cmi -exec.cmi : -frames.cmi : primitives.cmi ../bytecomp/instruct.cmi -history.cmi : -input_handling.cmi : primitives.cmi -int64ops.cmi : -lexer.cmi : parser.cmi -loadprinter.cmi : ../parsing/longident.cmi dynlink.cmi -parameters.cmi : -parser.cmi : parser_aux.cmi ../parsing/longident.cmi -parser_aux.cmi : primitives.cmi ../parsing/longident.cmi -pattern_matching.cmi : ../typing/typedtree.cmi parser_aux.cmi debugcom.cmi -pos.cmi : ../bytecomp/instruct.cmi -primitives.cmi : $(UNIXDIR)/unix.cmi -printval.cmi : ../typing/types.cmi ../typing/path.cmi parser_aux.cmi \ - ../typing/env.cmi debugcom.cmi -program_loading.cmi : primitives.cmi -program_management.cmi : -question.cmi : -show_information.cmi : ../bytecomp/instruct.cmi -show_source.cmi : ../bytecomp/instruct.cmi -source.cmi : -symbols.cmi : ../bytecomp/instruct.cmi -time_travel.cmi : primitives.cmi -trap_barrier.cmi : -unix_tools.cmi : $(UNIXDIR)/unix.cmi -breakpoints.cmo : symbols.cmi primitives.cmi pos.cmi \ - ../bytecomp/instruct.cmi exec.cmi debugcom.cmi checkpoints.cmi \ - breakpoints.cmi -breakpoints.cmx : symbols.cmx primitives.cmx pos.cmx \ - ../bytecomp/instruct.cmx exec.cmx debugcom.cmx checkpoints.cmx \ - breakpoints.cmi +breakpoints.cmo : symbols.cmi pos.cmi ../bytecomp/instruct.cmi exec.cmi \ + debugcom.cmi checkpoints.cmi breakpoints.cmi +breakpoints.cmx : symbols.cmx pos.cmx ../bytecomp/instruct.cmx exec.cmx \ + debugcom.cmx checkpoints.cmx breakpoints.cmi +breakpoints.cmi : ../bytecomp/instruct.cmi checkpoints.cmo : primitives.cmi int64ops.cmi debugcom.cmi checkpoints.cmi checkpoints.cmx : primitives.cmx int64ops.cmx debugcom.cmx checkpoints.cmi +checkpoints.cmi : primitives.cmi debugcom.cmi command_line.cmo : unix_tools.cmi $(UNIXDIR)/unix.cmi \ ../typing/types.cmi time_travel.cmi symbols.cmi source.cmi \ show_source.cmi show_information.cmi question.cmi program_management.cmi \ @@ -61,20 +26,15 @@ command_line.cmx : unix_tools.cmx $(UNIXDIR)/unix.cmx \ events.cmx eval.cmx ../typing/envaux.cmx ../typing/env.cmx \ debugger_config.cmx debugcom.cmx ../typing/ctype.cmx ../utils/config.cmx \ checkpoints.cmx breakpoints.cmx command_line.cmi +command_line.cmi : debugcom.cmo : primitives.cmi ../utils/misc.cmi int64ops.cmi \ input_handling.cmi debugcom.cmi debugcom.cmx : primitives.cmx ../utils/misc.cmx int64ops.cmx \ input_handling.cmx debugcom.cmi +debugcom.cmi : primitives.cmi debugger_config.cmo : int64ops.cmi debugger_config.cmi debugger_config.cmx : int64ops.cmx debugger_config.cmi -dynlink.cmo : ../bytecomp/symtable.cmi ../bytecomp/opcodes.cmo \ - ../utils/misc.cmi ../bytecomp/meta.cmi ../bytecomp/dll.cmi \ - ../utils/consistbl.cmi ../utils/config.cmi ../bytecomp/cmo_format.cmi \ - ../typing/cmi_format.cmi dynlink.cmi -dynlink.cmx : ../bytecomp/symtable.cmx ../bytecomp/opcodes.cmx \ - ../utils/misc.cmx ../bytecomp/meta.cmx ../bytecomp/dll.cmx \ - ../utils/consistbl.cmx ../utils/config.cmx ../bytecomp/cmo_format.cmi \ - ../typing/cmi_format.cmx dynlink.cmi +debugger_config.cmi : eval.cmo : ../typing/types.cmi ../bytecomp/symtable.cmi ../typing/subst.cmi \ printval.cmi ../typing/printtyp.cmi ../typing/predef.cmi \ ../typing/path.cmi parser_aux.cmi ../utils/misc.cmi \ @@ -87,34 +47,47 @@ eval.cmx : ../typing/types.cmx ../bytecomp/symtable.cmx ../typing/subst.cmx \ ../parsing/longident.cmx ../bytecomp/instruct.cmx ../typing/ident.cmx \ frames.cmx ../typing/env.cmx debugcom.cmx ../typing/ctype.cmx \ ../typing/btype.cmx eval.cmi +eval.cmi : ../typing/types.cmi ../typing/path.cmi parser_aux.cmi \ + ../parsing/longident.cmi ../bytecomp/instruct.cmi ../typing/ident.cmi \ + ../typing/env.cmi debugcom.cmi events.cmo : ../parsing/location.cmi ../bytecomp/instruct.cmi events.cmi events.cmx : ../parsing/location.cmx ../bytecomp/instruct.cmx events.cmi +events.cmi : ../bytecomp/instruct.cmi exec.cmo : exec.cmi exec.cmx : exec.cmi +exec.cmi : frames.cmo : symbols.cmi ../utils/misc.cmi ../bytecomp/instruct.cmi \ events.cmi debugcom.cmi frames.cmi frames.cmx : symbols.cmx ../utils/misc.cmx ../bytecomp/instruct.cmx \ events.cmx debugcom.cmx frames.cmi +frames.cmi : ../bytecomp/instruct.cmi history.cmo : primitives.cmi int64ops.cmi debugger_config.cmi \ checkpoints.cmi history.cmi history.cmx : primitives.cmx int64ops.cmx debugger_config.cmx \ checkpoints.cmx history.cmi +history.cmi : input_handling.cmo : $(UNIXDIR)/unix.cmi primitives.cmi \ input_handling.cmi input_handling.cmx : $(UNIXDIR)/unix.cmx primitives.cmx \ input_handling.cmi +input_handling.cmi : primitives.cmi int64ops.cmo : int64ops.cmi int64ops.cmx : int64ops.cmi +int64ops.cmi : lexer.cmo : parser.cmi lexer.cmi lexer.cmx : parser.cmx lexer.cmi +lexer.cmi : parser.cmi loadprinter.cmo : ../typing/types.cmi ../bytecomp/symtable.cmi printval.cmi \ ../typing/printtyp.cmi ../typing/path.cmi ../utils/misc.cmi \ ../parsing/longident.cmi ../typing/ident.cmi ../typing/env.cmi \ - dynlink.cmi ../typing/ctype.cmi ../utils/config.cmi loadprinter.cmi + ../typing/ctype.cmi ../utils/config.cmi ../driver/compdynlink.cmi \ + loadprinter.cmi loadprinter.cmx : ../typing/types.cmx ../bytecomp/symtable.cmx printval.cmx \ ../typing/printtyp.cmx ../typing/path.cmx ../utils/misc.cmx \ ../parsing/longident.cmx ../typing/ident.cmx ../typing/env.cmx \ - dynlink.cmx ../typing/ctype.cmx ../utils/config.cmx loadprinter.cmi + ../typing/ctype.cmx ../utils/config.cmx ../driver/compdynlink.cmi \ + loadprinter.cmi +loadprinter.cmi : ../parsing/longident.cmi ../driver/compdynlink.cmi main.cmo : unix_tools.cmi $(UNIXDIR)/unix.cmi time_travel.cmi \ show_information.cmi question.cmi program_management.cmi primitives.cmi \ parameters.cmi ../utils/misc.cmi input_handling.cmi frames.cmi exec.cmi \ @@ -131,22 +104,26 @@ parameters.cmo : primitives.cmi ../typing/envaux.cmi debugger_config.cmi \ ../utils/config.cmi parameters.cmi parameters.cmx : primitives.cmx ../typing/envaux.cmx debugger_config.cmx \ ../utils/config.cmx parameters.cmi +parameters.cmi : parser.cmo : parser_aux.cmi ../parsing/longident.cmi int64ops.cmi \ input_handling.cmi parser.cmi parser.cmx : parser_aux.cmi ../parsing/longident.cmx int64ops.cmx \ input_handling.cmx parser.cmi +parser.cmi : parser_aux.cmi ../parsing/longident.cmi +parser_aux.cmi : ../parsing/longident.cmi pattern_matching.cmo : ../typing/typedtree.cmi parser_aux.cmi \ ../utils/misc.cmi debugger_config.cmi debugcom.cmi ../typing/ctype.cmi \ pattern_matching.cmi pattern_matching.cmx : ../typing/typedtree.cmx parser_aux.cmi \ ../utils/misc.cmx debugger_config.cmx debugcom.cmx ../typing/ctype.cmx \ pattern_matching.cmi -pos.cmo : source.cmi primitives.cmi ../parsing/location.cmi \ - ../bytecomp/instruct.cmi pos.cmi -pos.cmx : source.cmx primitives.cmx ../parsing/location.cmx \ - ../bytecomp/instruct.cmx pos.cmi +pattern_matching.cmi : ../typing/typedtree.cmi parser_aux.cmi debugcom.cmi +pos.cmo : ../parsing/location.cmi ../bytecomp/instruct.cmi pos.cmi +pos.cmx : ../parsing/location.cmx ../bytecomp/instruct.cmx pos.cmi +pos.cmi : ../bytecomp/instruct.cmi primitives.cmo : $(UNIXDIR)/unix.cmi primitives.cmi primitives.cmx : $(UNIXDIR)/unix.cmx primitives.cmi +primitives.cmi : $(UNIXDIR)/unix.cmi printval.cmo : ../typing/types.cmi ../bytecomp/symtable.cmi \ ../typing/printtyp.cmi ../typing/path.cmi parser_aux.cmi \ ../typing/outcometree.cmi ../typing/oprint.cmi \ @@ -155,12 +132,15 @@ printval.cmx : ../typing/types.cmx ../bytecomp/symtable.cmx \ ../typing/printtyp.cmx ../typing/path.cmx parser_aux.cmi \ ../typing/outcometree.cmi ../typing/oprint.cmx \ ../toplevel/genprintval.cmx debugcom.cmx printval.cmi +printval.cmi : ../typing/types.cmi ../typing/path.cmi parser_aux.cmi \ + ../typing/env.cmi debugcom.cmi program_loading.cmo : unix_tools.cmi $(UNIXDIR)/unix.cmi \ primitives.cmi parameters.cmi input_handling.cmi debugger_config.cmi \ program_loading.cmi program_loading.cmx : unix_tools.cmx $(UNIXDIR)/unix.cmx \ primitives.cmx parameters.cmx input_handling.cmx debugger_config.cmx \ program_loading.cmi +program_loading.cmi : primitives.cmi program_management.cmo : unix_tools.cmi $(UNIXDIR)/unix.cmi \ time_travel.cmi symbols.cmi question.cmi program_loading.cmi \ primitives.cmi parameters.cmi int64ops.cmi input_handling.cmi history.cmi \ @@ -171,8 +151,10 @@ program_management.cmx : unix_tools.cmx $(UNIXDIR)/unix.cmx \ primitives.cmx parameters.cmx int64ops.cmx input_handling.cmx history.cmx \ ../typing/envaux.cmx debugger_config.cmx ../utils/config.cmx \ breakpoints.cmx program_management.cmi +program_management.cmi : question.cmo : primitives.cmi lexer.cmi input_handling.cmi question.cmi question.cmx : primitives.cmx lexer.cmx input_handling.cmx question.cmi +question.cmi : show_information.cmo : symbols.cmi source.cmi show_source.cmi printval.cmi \ parameters.cmi ../utils/misc.cmi ../bytecomp/instruct.cmi frames.cmi \ events.cmi debugcom.cmi checkpoints.cmi breakpoints.cmi \ @@ -181,22 +163,26 @@ show_information.cmx : symbols.cmx source.cmx show_source.cmx printval.cmx \ parameters.cmx ../utils/misc.cmx ../bytecomp/instruct.cmx frames.cmx \ events.cmx debugcom.cmx checkpoints.cmx breakpoints.cmx \ show_information.cmi +show_information.cmi : ../bytecomp/instruct.cmi show_source.cmo : source.cmi primitives.cmi parameters.cmi \ ../parsing/location.cmi ../bytecomp/instruct.cmi events.cmi \ debugger_config.cmi show_source.cmi show_source.cmx : source.cmx primitives.cmx parameters.cmx \ ../parsing/location.cmx ../bytecomp/instruct.cmx events.cmx \ debugger_config.cmx show_source.cmi +show_source.cmi : ../bytecomp/instruct.cmi source.cmo : primitives.cmi ../utils/misc.cmi debugger_config.cmi \ ../utils/config.cmi source.cmi source.cmx : primitives.cmx ../utils/misc.cmx debugger_config.cmx \ ../utils/config.cmx source.cmi +source.cmi : symbols.cmo : ../bytecomp/symtable.cmi program_loading.cmi \ ../bytecomp/instruct.cmi events.cmi debugger_config.cmi debugcom.cmi \ checkpoints.cmi ../bytecomp/bytesections.cmi symbols.cmi symbols.cmx : ../bytecomp/symtable.cmx program_loading.cmx \ ../bytecomp/instruct.cmx events.cmx debugger_config.cmx debugcom.cmx \ checkpoints.cmx ../bytecomp/bytesections.cmx symbols.cmi +symbols.cmi : ../bytecomp/instruct.cmi time_travel.cmo : trap_barrier.cmi symbols.cmi question.cmi \ program_loading.cmi primitives.cmi ../utils/misc.cmi int64ops.cmi \ ../bytecomp/instruct.cmi input_handling.cmi exec.cmi events.cmi \ @@ -207,9 +193,10 @@ time_travel.cmx : trap_barrier.cmx symbols.cmx question.cmx \ ../bytecomp/instruct.cmx input_handling.cmx exec.cmx events.cmx \ debugger_config.cmx debugcom.cmx checkpoints.cmx breakpoints.cmx \ time_travel.cmi +time_travel.cmi : primitives.cmi trap_barrier.cmo : exec.cmi debugcom.cmi checkpoints.cmi trap_barrier.cmi trap_barrier.cmx : exec.cmx debugcom.cmx checkpoints.cmx trap_barrier.cmi -unix_tools.cmo : $(UNIXDIR)/unix.cmi primitives.cmi ../utils/misc.cmi \ - unix_tools.cmi -unix_tools.cmx : $(UNIXDIR)/unix.cmx primitives.cmx ../utils/misc.cmx \ - unix_tools.cmi +trap_barrier.cmi : +unix_tools.cmo : $(UNIXDIR)/unix.cmi ../utils/misc.cmi unix_tools.cmi +unix_tools.cmx : $(UNIXDIR)/unix.cmx ../utils/misc.cmx unix_tools.cmi +unix_tools.cmi : $(UNIXDIR)/unix.cmi diff --git a/debugger/Makefile.shared b/debugger/Makefile.shared index 520f883d..aed8aa12 100644 --- a/debugger/Makefile.shared +++ b/debugger/Makefile.shared @@ -18,7 +18,8 @@ CAMLRUN ?= ../boot/ocamlrun CAMLYACC ?= ../boot/ocamlyacc CAMLC=$(CAMLRUN) ../ocamlc -nostdlib -I ../stdlib -COMPFLAGS=-warn-error A -safe-string $(INCLUDES) +COMPFLAGS=$(INCLUDES) -absname -w +a-4-9-41-42-44-45-48 -warn-error A \ + -safe-string -strict-sequence -strict-formats LINKFLAGS=-linkall -I $(UNIXDIR) YACCFLAGS= CAMLLEX=$(CAMLRUN) ../boot/ocamllex @@ -29,7 +30,7 @@ INSTALL_BINDIR=$(DESTDIR)$(BINDIR) INCLUDES=\ -I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../toplevel \ - -I $(UNIXDIR) + -I ../driver -I $(UNIXDIR) OTHEROBJS=\ $(UNIXDIR)/unix.cma \ @@ -51,12 +52,11 @@ OTHEROBJS=\ ../typing/envaux.cmo \ ../bytecomp/runtimedef.cmo ../bytecomp/bytesections.cmo \ ../bytecomp/dll.cmo ../bytecomp/meta.cmo ../bytecomp/symtable.cmo \ - ../bytecomp/opcodes.cmo \ + ../bytecomp/opcodes.cmo ../driver/compdynlink.cmo \ ../toplevel/genprintval.cmo OBJS=\ - dynlink.cmo \ int64ops.cmo \ primitives.cmo \ unix_tools.cmo \ @@ -110,7 +110,7 @@ clean:: $(CAMLC) -c $(COMPFLAGS) $< depend: beforedepend - $(CAMLDEP) $(DEPFLAGS) *.mli *.ml \ + $(CAMLDEP) -slash $(DEPFLAGS) *.mli *.ml \ | sed -e 's,$(UNIXDIR)/,$$(UNIXDIR)/,' > .depend lexer.ml: lexer.mll @@ -125,13 +125,4 @@ clean:: rm -f parser.ml parser.mli beforedepend:: parser.ml parser.mli -dynlink.ml: ../otherlibs/dynlink/dynlink.ml - grep -v 'REMOVE_ME for ../../debugger/dynlink.ml' \ - ../otherlibs/dynlink/dynlink.ml >dynlink.ml -dynlink.mli: ../otherlibs/dynlink/dynlink.mli - cp ../otherlibs/dynlink/dynlink.mli . -clean:: - rm -f dynlink.ml dynlink.mli -beforedepend:: dynlink.ml dynlink.mli - include .depend diff --git a/debugger/breakpoints.ml b/debugger/breakpoints.ml index 587b9164..edba0428 100644 --- a/debugger/breakpoints.ml +++ b/debugger/breakpoints.ml @@ -19,7 +19,6 @@ open Checkpoints open Debugcom open Instruct -open Primitives open Printf (*** Debugging. ***) @@ -137,7 +136,7 @@ let execute_without_breakpoints f = f (); change_version version pos with - x -> + _ -> change_version version pos (* Add a position in the position list. *) diff --git a/debugger/breakpoints.mli b/debugger/breakpoints.mli index 2d5a8d87..d0e76c36 100644 --- a/debugger/breakpoints.mli +++ b/debugger/breakpoints.mli @@ -16,7 +16,6 @@ (******************************* Breakpoints ***************************) -open Primitives open Instruct (*** Debugging. ***) diff --git a/debugger/command_line.ml b/debugger/command_line.ml index 4cb6a4fc..b8b09134 100644 --- a/debugger/command_line.ml +++ b/debugger/command_line.ml @@ -179,7 +179,7 @@ let interprete_line ppf line = i.instr_action ppf lexbuf; resume_user_input (); i.instr_repeat - | l -> + | _ -> error "Ambiguous command." end | None -> @@ -216,7 +216,7 @@ let line_loop ppf line_buffer = error ("System error: " ^ s) *) (** Instructions. **) -let instr_cd ppf lexbuf = +let instr_cd _ppf lexbuf = let dir = argument_eol argument lexbuf in if ask_kill_program () then try @@ -225,7 +225,7 @@ let instr_cd ppf lexbuf = | Sys_error s -> error s -let instr_shell ppf lexbuf = +let instr_shell _ppf lexbuf = let cmdarg = argument_list_eol argument lexbuf in let cmd = String.concat " " cmdarg in (* perhaps we should use $SHELL -c ? *) @@ -233,7 +233,7 @@ let instr_shell ppf lexbuf = if (err != 0) then eprintf "Shell command %S failed with exit code %d\n%!" cmd err -let instr_env ppf lexbuf = +let instr_env _ppf lexbuf = let cmdarg = argument_list_eol argument lexbuf in let cmdarg = string_trim (String.concat " " cmdarg) in if cmdarg <> "" then @@ -286,7 +286,7 @@ let instr_dir ppf lexbuf = dirs) Debugger_config.load_path_for -let instr_kill ppf lexbuf = +let instr_kill _ppf lexbuf = eol lexbuf; if not !loaded then error "The program is not being run."; if (yes_or_no "Kill the program being debugged") then begin @@ -393,7 +393,7 @@ let print_info_list ppf = let pr_infos ppf = List.iter (fun i -> fprintf ppf "%s@ " i.info_name) in fprintf ppf "List of info commands: %a@." pr_infos !info_list -let instr_complete ppf lexbuf = +let instr_complete _ppf lexbuf = let ppf = Format.err_formatter in let rec print_list l = try @@ -465,7 +465,7 @@ let instr_help ppf lexbuf = find_variable (fun v _ _ -> print_help ("show " ^ v.var_name) ("show " ^ v.var_help)) - (fun v -> + (fun _v -> print_help "show" "display debugger variable."; print_variable_list ppf) ppf @@ -585,8 +585,8 @@ let instr_source ppf lexbuf = let instr_set = find_variable - (fun {var_action = (funct, _)} ppf lexbuf -> funct lexbuf) - (function ppf -> error "Argument required.") + (fun {var_action = (funct, _)} _ppf lexbuf -> funct lexbuf) + (function _ppf -> error "Argument required.") let instr_show = find_variable @@ -600,8 +600,8 @@ let instr_show = let instr_info = find_info - (fun i ppf lexbuf -> i.info_action lexbuf) - (function ppf -> + (fun i _ppf lexbuf -> i.info_action lexbuf) + (function _ppf -> error "\"info\" must be followed by the name of an info command.") let instr_break ppf lexbuf = @@ -673,7 +673,7 @@ let instr_break ppf lexbuf = | Not_found -> eprintf "Can\'t find any event there.@." -let instr_delete ppf lexbuf = +let instr_delete _ppf lexbuf = match integer_list_eol Lexer.lexeme lexbuf with | [] -> if breakpoints_count () <> 0 && yes_or_no "Delete all breakpoints" @@ -771,7 +771,7 @@ let instr_last ppf lexbuf = go_to (History.previous_time count); show_current_event ppf -let instr_list ppf lexbuf = +let instr_list _ppf lexbuf = let (mo, beg, e) = list_arguments_eol Lexer.lexeme lexbuf in let (curr_mod, line, column) = try @@ -866,9 +866,9 @@ let loading_mode_variable ppf = (find_ident "loading mode" (matching_elements (ref loading_modes) fst) - (fun (_, mode) ppf lexbuf -> + (fun (_, mode) _ppf lexbuf -> eol lexbuf; set_launching_function mode) - (function ppf -> error "Syntax error.") + (function _ppf -> error "Syntax error.") ppf), function ppf -> let rec find = function @@ -946,7 +946,7 @@ let info_breakpoints ppf lexbuf = end ;; -let info_events ppf lexbuf = +let info_events _ppf lexbuf = ensure_loaded (); let mdle = convert_module (module_of_longident (opt_longident_eol Lexer.lexeme lexbuf)) @@ -1210,7 +1210,7 @@ It can be either:\n\ var_action = follow_fork_variable; var_help = "process to follow after forking.\n\ -It can be either : +It can be either :\n\ child: the newly created process.\n\ parent: the process that called fork.\n" }]; diff --git a/debugger/debugcom.ml b/debugger/debugcom.ml index a8079cbc..b70eedd1 100644 --- a/debugger/debugcom.ml +++ b/debugger/debugcom.ml @@ -282,7 +282,7 @@ module Remote_value = Remote(input_remote_value !conn.io_in) let closure_code = function - | Local obj -> assert false + | Local _ -> assert false | Remote v -> output_char !conn.io_out 'C'; output_remote_value !conn.io_out v; diff --git a/debugger/eval.ml b/debugger/eval.ml index e4e9aaf1..e6baa80b 100644 --- a/debugger/eval.ml +++ b/debugger/eval.ml @@ -61,12 +61,12 @@ let rec path event = function | None -> raise(Error(Unbound_identifier id)) end - | Pdot(root, fieldname, pos) -> + | Pdot(root, _fieldname, pos) -> let v = path event root in if not (Debugcom.Remote_value.is_block v) then raise(Error(Not_initialized_yet root)); Debugcom.Remote_value.field v pos - | Papply(p1, p2) -> + | Papply _ -> fatal_error "Eval.path: Papply" let rec expression event env = function @@ -135,10 +135,10 @@ let rec expression event env = function | E_field(arg, lbl) -> let (v, ty) = expression event env arg in begin match (Ctype.repr(Ctype.expand_head_opt env ty)).desc with - Tconstr(path, args, _) -> + Tconstr(path, _, _) -> let tydesc = Env.find_type path env in begin match tydesc.type_kind with - Type_record(lbl_list, repr) -> + Type_record(lbl_list, _repr) -> let (pos, ty_res) = find_label lbl env ty path tydesc 0 lbl_list in (Debugcom.Remote_value.field v pos, ty_res) diff --git a/debugger/exec.ml b/debugger/exec.ml index 0fc59528..df940165 100644 --- a/debugger/exec.ml +++ b/debugger/exec.ml @@ -20,7 +20,7 @@ let interrupted = ref false let is_protected = ref false -let break signum = +let break _signum = if !is_protected then interrupted := true else raise Sys.Break diff --git a/debugger/frames.ml b/debugger/frames.ml index 2db2e1b1..96b7ce15 100644 --- a/debugger/frames.ml +++ b/debugger/frames.ml @@ -125,6 +125,6 @@ let do_backtrace action = let stack_depth () = let num_frames = ref 0 in - do_backtrace (function Some ev -> incr num_frames; true + do_backtrace (function Some _ev -> incr num_frames; true | None -> num_frames := -1; false); !num_frames diff --git a/debugger/frames.mli b/debugger/frames.mli index faaf516b..514aa2e3 100644 --- a/debugger/frames.mli +++ b/debugger/frames.mli @@ -17,7 +17,6 @@ (****************************** Frames *********************************) open Instruct -open Primitives (* Current frame number *) val current_frame : int ref diff --git a/debugger/lexer.mll b/debugger/lexer.mll index 133d2732..8570b152 100644 --- a/debugger/lexer.mll +++ b/debugger/lexer.mll @@ -78,7 +78,7 @@ and lexeme = (* Read a lexeme *) | "." { DOT } | "#" - { SHARP } + { HASH } | "@" { AT } | "$" diff --git a/debugger/loadprinter.ml b/debugger/loadprinter.ml index 113ae89f..a1c2fcfe 100644 --- a/debugger/loadprinter.ml +++ b/debugger/loadprinter.ml @@ -23,7 +23,7 @@ open Types (* Error report *) type error = - | Load_failure of Dynlink.error + | Load_failure of Compdynlink.error | Unbound_identifier of Longident.t | Unavailable_module of string * Longident.t | Wrong_type of Longident.t @@ -41,8 +41,8 @@ let use_debugger_symtable fn arg = let old_symtable = Symtable.current_state() in begin match !debugger_symtable with | None -> - Dynlink.init(); - Dynlink.allow_unsafe_modules true; + Compdynlink.init(); + Compdynlink.allow_unsafe_modules true; debugger_symtable := Some(Symtable.current_state()) | Some st -> Symtable.restore_state st @@ -63,7 +63,7 @@ open Format let rec loadfiles ppf name = try let filename = find_in_path !Config.load_path name in - use_debugger_symtable Dynlink.loadfile filename; + use_debugger_symtable Compdynlink.loadfile filename; let d = Filename.dirname name in if d <> Filename.current_dir_name then begin if not (List.mem d !Config.load_path) then @@ -72,7 +72,7 @@ let rec loadfiles ppf name = fprintf ppf "File %s loaded@." filename; true with - | Dynlink.Error (Dynlink.Unavailable_unit unit) -> + | Compdynlink.Error (Compdynlink.Unavailable_unit unit) -> loadfiles ppf (String.uncapitalize_ascii unit ^ ".cmo") && loadfiles ppf name @@ -82,7 +82,7 @@ let rec loadfiles ppf name = | Sys_error msg -> fprintf ppf "%s: %s@." name msg; false - | Dynlink.Error e -> + | Compdynlink.Error e -> raise(Error(Load_failure e)) let loadfile ppf name = @@ -94,8 +94,8 @@ let loadfile ppf name = let rec eval_path = function Pident id -> Symtable.get_global_value id - | Pdot(p, s, pos) -> Obj.field (eval_path p) pos - | Papply(p1, p2) -> fatal_error "Loadprinter.eval_path" + | Pdot(p, _, pos) -> Obj.field (eval_path p) pos + | Papply _ -> fatal_error "Loadprinter.eval_path" (* Install, remove a printer (as in toplevel/topdirs) *) @@ -109,7 +109,7 @@ let () = ignore (Env.read_signature "Topdirs" topdirs) let match_printer_type desc typename = - let (printer_type, _) = + let printer_type = try Env.lookup_type (Ldot(Lident "Topdirs", typename)) Env.empty with Not_found -> @@ -146,13 +146,13 @@ let install_printer ppf lid = raise(Error(Unavailable_module(s, lid))) in let print_function = if is_old_style then - (fun formatter repr -> Obj.obj v (Obj.obj repr)) + (fun _formatter repr -> Obj.obj v (Obj.obj repr)) else (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in Printval.install_printer path ty_arg ppf print_function let remove_printer lid = - let (ty_arg, path, is_old_style) = find_printer_type lid in + let (_ty_arg, path, _is_old_style) = find_printer_type lid in try Printval.remove_printer path with Not_found -> @@ -165,7 +165,7 @@ open Format let report_error ppf = function | Load_failure e -> fprintf ppf "@[Error during code loading: %s@]@." - (Dynlink.error_message e) + (Compdynlink.error_message e) | Unbound_identifier lid -> fprintf ppf "@[Unbound identifier %a@]@." Printtyp.longident lid diff --git a/debugger/loadprinter.mli b/debugger/loadprinter.mli index 8fc6f7a6..c645e8d2 100644 --- a/debugger/loadprinter.mli +++ b/debugger/loadprinter.mli @@ -24,7 +24,7 @@ val remove_printer : Longident.t -> unit (* Error report *) type error = - | Load_failure of Dynlink.error + | Load_failure of Compdynlink.error | Unbound_identifier of Longident.t | Unavailable_module of string * Longident.t | Wrong_type of Longident.t diff --git a/debugger/main.ml b/debugger/main.ml index 50ffcf5c..4f2b830f 100644 --- a/debugger/main.ml +++ b/debugger/main.ml @@ -29,7 +29,7 @@ open Primitives let line_buffer = Lexing.from_function read_user_input -let rec loop ppf = line_loop ppf line_buffer +let loop ppf = line_loop ppf line_buffer let current_duration = ref (-1L) diff --git a/debugger/parameters.ml b/debugger/parameters.ml index f9192a7a..a4d647c4 100644 --- a/debugger/parameters.ml +++ b/debugger/parameters.ml @@ -20,7 +20,6 @@ open Primitives open Config open Debugger_config -let program_loaded = ref false let program_name = ref "" let socket_name = ref "" let arguments = ref "" diff --git a/debugger/parser.mly b/debugger/parser.mly index 060aee74..36864b04 100644 --- a/debugger/parser.mly +++ b/debugger/parser.mly @@ -31,7 +31,7 @@ open Parser_aux %token STAR /* * */ %token MINUS /* - */ %token DOT /* . */ -%token SHARP /* # */ +%token HASH /* # */ %token AT /* @ */ %token DOLLAR /* $ */ %token BANG /* ! */ @@ -238,7 +238,7 @@ break_argument_eol : | integer_eol { BA_pc $1 } | expression end_of_line { BA_function $1 } | AT opt_longident INTEGER opt_integer_eol { BA_pos1 ($2, (to_int $3), $4)} - | AT opt_longident SHARP integer_eol { BA_pos2 ($2, $4) } + | AT opt_longident HASH integer_eol { BA_pos2 ($2, $4) } ; /* Arguments for list */ diff --git a/debugger/parser_aux.mli b/debugger/parser_aux.mli index a218a104..67c84462 100644 --- a/debugger/parser_aux.mli +++ b/debugger/parser_aux.mli @@ -14,10 +14,6 @@ (* *) (**************************************************************************) -(*open Globals*) - -open Primitives - type expression = E_ident of Longident.t (* x or Mod.x *) | E_name of int (* $xxx *) diff --git a/debugger/pos.ml b/debugger/pos.ml index 7546df50..cc164e68 100644 --- a/debugger/pos.ml +++ b/debugger/pos.ml @@ -16,8 +16,6 @@ open Instruct;; open Lexing;; open Location;; -open Primitives;; -open Source;; let get_desc ev = let loc = ev.ev_loc in diff --git a/debugger/primitives.ml b/debugger/primitives.ml index 498a8c54..ac695137 100644 --- a/debugger/primitives.ml +++ b/debugger/primitives.ml @@ -95,23 +95,6 @@ let isprefix s1 s2 = let l1 = String.length s1 and l2 = String.length s2 in (l1 = l2 && s1 = s2) || (l1 < l2 && s1 = String.sub s2 0 l1) -(* Split a string at the given delimiter char *) - -let split_string sep str = - let rec split i j = - if j >= String.length str then - if i >= j then [] else [String.sub str i (j-i)] - else if str.[j] = sep then - if i >= j - then skip_sep (j+1) - else String.sub str i (j-i) :: skip_sep (j+1) - else - split i (j+1) - and skip_sep j = - if j < String.length str && str.[j] = sep - then skip_sep (j+1) - else split j j - in split 0 0 (*** I/O channels ***) diff --git a/debugger/primitives.mli b/debugger/primitives.mli index f977b498..2be9032f 100644 --- a/debugger/primitives.mli +++ b/debugger/primitives.mli @@ -50,9 +50,6 @@ val string_trim : string -> string (* isprefix s1 s2 returns true if s1 is a prefix of s2. *) val isprefix : string -> string -> bool -(* Split a string at the given delimiter char *) -val split_string : char -> string -> string list - (*** I/O channels ***) type io_channel = { diff --git a/debugger/printval.ml b/debugger/printval.ml index 30f111ea..1175a96c 100644 --- a/debugger/printval.ml +++ b/debugger/printval.ml @@ -40,7 +40,7 @@ let name_value v ty = let find_named_value name = Hashtbl.find named_values name -let check_depth ppf depth obj ty = +let check_depth depth obj ty = if depth <= 0 then begin let n = name_value obj ty in Some (Outcometree.Oval_stuff ("$" ^ string_of_int n)) @@ -57,19 +57,19 @@ module EvalPath = with Symtable.Error _ -> raise Error end - | Pdot(root, fieldname, pos) -> + | Pdot(root, _fieldname, pos) -> let v = eval_path env root in if not (Debugcom.Remote_value.is_block v) then raise Error else Debugcom.Remote_value.field v pos - | Papply(p1, p2) -> + | Papply _ -> raise Error let same_value = Debugcom.Remote_value.same end module Printer = Genprintval.Make(Debugcom.Remote_value)(EvalPath) -let install_printer path ty ppf fn = +let install_printer path ty _ppf fn = Printer.install_printer path ty (fun ppf remote_val -> try @@ -90,7 +90,7 @@ let print_exception ppf obj = let print_value max_depth env obj (ppf : Format.formatter) ty = let t = Printer.outval_of_value !max_printer_steps max_depth - (check_depth ppf) env obj ty in + check_depth env obj ty in !Oprint.out_value ppf t let print_named_value max_depth exp env obj ppf ty = diff --git a/debugger/source.ml b/debugger/source.ml index 4ab79363..ff41e3fc 100644 --- a/debugger/source.ml +++ b/debugger/source.ml @@ -67,8 +67,6 @@ type buffer = string * (int * int) list ref let buffer_max_count = ref 10 -let cache_size = 30 - let buffer_list = ref ([] : (string * buffer) list) @@ -101,7 +99,7 @@ let insert_pos buffer ((position, line) as pair) = function [] -> [(position, line)] - | ((pos, lin) as a::l) as l' -> + | ((_pos, lin) as a::l) as l' -> if lin < line then pair::l' else if lin = line then @@ -141,13 +139,13 @@ let line_of_pos buffer position = raise Out_of_range else (0, 1) - | ((pos, line) as pair)::l -> + | ((pos, _line) as pair)::l -> if pos > position then find l else pair and find_line previous = - let (pos, line) as next = next_line buffer previous in + let (pos, _line) as next = next_line buffer previous in if pos <= position then find_line next else @@ -166,7 +164,7 @@ let pos_of_line buffer line = raise Out_of_range else (0, 1) - | ((pos, lin) as pair)::l -> + | ((_pos, lin) as pair)::l -> if lin > line then find l else diff --git a/debugger/symbols.ml b/debugger/symbols.ml index 9a9c8f9c..dd20d8f9 100644 --- a/debugger/symbols.ml +++ b/debugger/symbols.ml @@ -62,7 +62,7 @@ let read_symbols' bytecode_file = let num_eventlists = input_binary_int ic in let dirs = ref StringSet.empty in let eventlists = ref [] in - for i = 1 to num_eventlists do + for _i = 1 to num_eventlists do let orig = input_binary_int ic in let evl = (input_value ic : debug_event list) in (* Relocate events in event list *) @@ -182,7 +182,7 @@ let event_near_pos md char = (* Flip "event" bit on all instructions *) let set_all_events () = Hashtbl.iter - (fun pc ev -> + (fun _pc ev -> match ev.ev_kind with Event_pseudo -> () | _ -> Debugcom.set_event ev.ev_pos) diff --git a/debugger/time_travel.ml b/debugger/time_travel.ml index c7d6e9a8..ec72413b 100644 --- a/debugger/time_travel.ml +++ b/debugger/time_travel.ml @@ -271,7 +271,7 @@ let rec stop_on_event report = None -> find_event () | Some _ -> () end - | {rep_type = Trap_barrier; rep_stack_pointer = trap_frame} -> + | {rep_type = Trap_barrier} -> (* No event at current position. *) find_event () | _ -> @@ -452,7 +452,7 @@ let go_to time = (* Return the time of the last breakpoint *) (* between current time and `max_time'. *) -let rec find_last_breakpoint max_time = +let find_last_breakpoint max_time = let rec find break = let time = current_time () in step_forward (max_time -- time); @@ -559,14 +559,14 @@ let next_1 () = None -> (* Beginning of the program. *) step _1 | Some event1 -> - let (frame1, pc1) = initial_frame() in + let (frame1, _pc1) = initial_frame() in step _1; if not !interrupted then begin Symbols.update_current_event (); match !current_event with None -> () | Some event2 -> - let (frame2, pc2) = initial_frame() in + let (frame2, _pc2) = initial_frame() in (* Call `finish' if we've entered a function. *) if frame1 >= 0 && frame2 >= 0 && frame2 - event2.ev_stacksize > frame1 - event1.ev_stacksize @@ -627,14 +627,14 @@ let previous_1 () = None -> (* End of the program. *) step _minus1 | Some event1 -> - let (frame1, pc1) = initial_frame() in + let (frame1, _pc1) = initial_frame() in step _minus1; if not !interrupted then begin Symbols.update_current_event (); match !current_event with None -> () | Some event2 -> - let (frame2, pc2) = initial_frame() in + let (frame2, _pc2) = initial_frame() in (* Call `start' if we've entered a function. *) if frame1 >= 0 && frame2 >= 0 && frame2 - event2.ev_stacksize > frame1 - event1.ev_stacksize diff --git a/debugger/unix_tools.ml b/debugger/unix_tools.ml index faf5fb7b..4771253b 100644 --- a/debugger/unix_tools.ml +++ b/debugger/unix_tools.ml @@ -18,7 +18,6 @@ open Misc open Unix -open Primitives (*** Convert a socket name into a socket address. ***) let convert_address address = diff --git a/driver/compdynlink.mlno b/driver/compdynlink.mlno new file mode 100644 index 00000000..d7d685bb --- /dev/null +++ b/driver/compdynlink.mlno @@ -0,0 +1,57 @@ +#2 "driver/compdynlink.mlno" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Dynamic loading of .cmx files *) + +type linking_error = + Undefined_global of string + | Unavailable_primitive of string + | Uninitialized_global of string + +type error = + Not_a_bytecode_file of string + | Inconsistent_import of string + | Unavailable_unit of string + | Unsafe_file + | Linking_error of string * linking_error + | Corrupted_interface of string + | File_not_found of string + | Cannot_open_dll of string + | Inconsistent_implementation of string + +exception Error of error + +let not_available _ = + failwith "No support for native dynlink on this OS" + +let default_available_units = not_available + +let init = not_available + +let loadfile = not_available +let loadfile_private = not_available +let allow_only = not_available +let prohibit = not_available + +let digest_interface = not_available +let add_interfaces = not_available +let add_available_units = not_available +let clear_available_units = not_available +let allow_unsafe_modules = not_available +let error_message = not_available + +let is_native = true +let adapt_filename f = Filename.chop_extension f ^ ".cmxs" diff --git a/driver/compenv.ml b/driver/compenv.ml index cbdb59c4..c829820c 100644 --- a/driver/compenv.ml +++ b/driver/compenv.ml @@ -20,7 +20,7 @@ let output_prefix name = match !output_name with | None -> name | Some n -> if !compile_only then (output_name := None; n) else name in - Misc.chop_extension_if_any oname + Filename.remove_extension oname let print_version_and_library compiler = Printf.printf "The OCaml %s, version " compiler; @@ -106,7 +106,7 @@ type readenv_position = exception SyntaxError of string let parse_args s = - let args = Misc.split s ',' in + let args = String.split_on_char ',' s in let rec iter is_after args before after = match args with [] -> @@ -158,6 +158,7 @@ let int_option_setter ppf name option s = (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 @@ -165,6 +166,9 @@ let float_setter ppf name option s = Location.print_warning Location.none ppf (Warnings.Bad_env_variable ("OCAMLPARAM", Printf.sprintf "non-float parameter for \"%s\"" name)) +*) + +let load_plugin = ref (fun _ -> ()) let check_bool ppf name s = match s with @@ -201,6 +205,7 @@ let read_one_param ppf position name v = | "strict-sequence" -> set "strict-sequence" [ strict_sequence ] v | "strict-formats" -> set "strict-formats" [ strict_formats ] v | "thread" -> set "thread" [ use_threads ] v + | "unboxed-types" -> set "unboxed-types" [ unboxed_types ] v | "unsafe" -> set "unsafe" [ fast ] v | "verbose" -> set "verbose" [ verbose ] v | "nopervasives" -> set "nopervasives" [ nopervasives ] v @@ -398,6 +403,8 @@ let read_one_param ppf position name v = | "timings" -> set "timings" [ print_timings ] v + | "plugin" -> !load_plugin v + | _ -> if not (List.mem name !can_discard) then begin can_discard := name :: !can_discard; @@ -520,5 +527,109 @@ let readenv ppf position = all_ccopts := !last_ccopts @ !first_ccopts; all_ppx := !last_ppx @ !first_ppx -let get_objfiles () = - List.rev (!last_objfiles @ !objfiles @ !first_objfiles) +let get_objfiles ~with_ocamlparam = + if with_ocamlparam then + List.rev (!last_objfiles @ !objfiles @ !first_objfiles) + else + List.rev !objfiles + + + + + + +type deferred_action = + | ProcessImplementation of string + | ProcessInterface of string + | ProcessCFile of string + | ProcessOtherFile of string + | ProcessObjects of string list + | ProcessDLLs of string list + +let c_object_of_filename name = + Filename.chop_suffix (Filename.basename name) ".c" ^ Config.ext_obj + +let process_action + (ppf, implementation, interface, ocaml_mod_ext, ocaml_lib_ext) action = + match action with + | ProcessImplementation name -> + readenv ppf (Before_compile name); + let opref = output_prefix name in + implementation ppf name opref; + objfiles := (opref ^ ocaml_mod_ext) :: !objfiles + | ProcessInterface name -> + readenv ppf (Before_compile name); + let opref = output_prefix name in + interface ppf name opref; + if !make_package then objfiles := (opref ^ ".cmi") :: !objfiles + | ProcessCFile name -> + readenv ppf (Before_compile name); + Location.input_name := name; + if Ccomp.compile_file name <> 0 then exit 2; + ccobjs := c_object_of_filename name :: !ccobjs + | ProcessObjects names -> + ccobjs := names @ !ccobjs + | ProcessDLLs names -> + dllibs := names @ !dllibs + | ProcessOtherFile name -> + if Filename.check_suffix name ocaml_mod_ext + || Filename.check_suffix name ocaml_lib_ext then + objfiles := name :: !objfiles + else if Filename.check_suffix name ".cmi" && !make_package then + objfiles := name :: !objfiles + else if Filename.check_suffix name Config.ext_obj + || Filename.check_suffix name Config.ext_lib then + ccobjs := name :: !ccobjs + else if not !native_code && Filename.check_suffix name Config.ext_dll then + dllibs := name :: !dllibs + else + raise(Arg.Bad("don't know what to do with " ^ name)) + + +let action_of_file name = + if Filename.check_suffix name ".ml" + || Filename.check_suffix name ".mlt" then + ProcessImplementation name + else if Filename.check_suffix name !Config.interface_suffix then + ProcessInterface name + else if Filename.check_suffix name ".c" then + ProcessCFile name + else + ProcessOtherFile name + +let deferred_actions = ref [] +let defer action = + deferred_actions := action :: !deferred_actions + +let anonymous filename = defer (action_of_file filename) +let impl filename = defer (ProcessImplementation filename) +let intf filename = defer (ProcessInterface filename) + +let process_deferred_actions env = + let final_output_name = !output_name in + (* Make sure the intermediate products don't clash with the final one + when we're invoked like: ocamlopt -o foo bar.c baz.ml. *) + if not !compile_only then output_name := None; + begin + match final_output_name with + | None -> () + | Some output_name -> + if !compile_only then begin + if List.filter (function + | ProcessCFile name -> c_object_of_filename name <> output_name + | _ -> false) !deferred_actions <> [] then + fatal "Options -c and -o are incompatible when compiling C files"; + + if List.length (List.filter (function + | ProcessImplementation _ + | ProcessInterface _ + | _ -> false) !deferred_actions) > 1 then + fatal "Options -c -o are incompatible with compiling multiple files" + end; + end; + if !make_archive && List.exists (function + | ProcessOtherFile name -> Filename.check_suffix name ".cmxa" + | _ -> false) !deferred_actions then + fatal "Option -a cannot be used with .cmxa input files."; + List.iter (process_action env) (List.rev !deferred_actions); + output_name := final_output_name; diff --git a/driver/compenv.mli b/driver/compenv.mli index 413420d4..0ee9871a 100644 --- a/driver/compenv.mli +++ b/driver/compenv.mli @@ -30,8 +30,13 @@ val first_include_dirs : string list ref val last_include_dirs : string list ref val implicit_modules : string list ref +(* function to call on plugin=XXX *) +val load_plugin : (string -> unit) ref + (* return the list of objfiles, after OCAMLPARAM and List.rev *) -val get_objfiles : unit -> string list +val get_objfiles : with_ocamlparam:bool -> string list +val last_objfiles : string list ref +val first_objfiles : string list ref type filename = string @@ -46,3 +51,28 @@ val is_unit_name : string -> bool (* [check_unit_name ppf filename name] prints a warning in [filename] on [ppf] if [name] should not be used as a module name. *) val check_unit_name : Format.formatter -> string -> string -> unit + +(* Deferred actions of the compiler, while parsing arguments *) + +type deferred_action = + | ProcessImplementation of string + | ProcessInterface of string + | ProcessCFile of string + | ProcessOtherFile of string + | ProcessObjects of string list + | ProcessDLLs of string list + +val c_object_of_filename : string -> string + +val defer : deferred_action -> unit +val anonymous : string -> unit +val impl : string -> unit +val intf : string -> unit + +val process_deferred_actions : + Format.formatter * + (Format.formatter -> string -> string -> unit) * (* compile implementation *) + (Format.formatter -> string -> string -> unit) * (* compile interface *) + string * (* ocaml module extension *) + string -> (* ocaml library extension *) + unit diff --git a/driver/compile.ml b/driver/compile.ml index 053327f2..0d7325d3 100644 --- a/driver/compile.ml +++ b/driver/compile.ml @@ -32,9 +32,10 @@ let interface ppf sourcefile outputprefix = Env.set_unit_name modulename; let initial_env = Compmisc.initial_env () in let ast = Pparse.parse_interface ~tool_name ppf sourcefile in + if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast; if !Clflags.dump_source then fprintf ppf "%a@." Pprintast.signature ast; - let tsg = Typemod.type_interface initial_env ast in + let tsg = Typemod.type_interface sourcefile initial_env ast in if !Clflags.dump_typedtree then fprintf ppf "%a@." Printtyped.interface tsg; let sg = tsg.sig_type in if !Clflags.print_types then @@ -75,29 +76,30 @@ let implementation ppf sourcefile outputprefix = (Typemod.type_implementation sourcefile outputprefix modulename env) ++ print_if ppf Clflags.dump_typedtree Printtyped.implementation_with_coercion - in + in if !Clflags.print_types then begin Warnings.check_fatal (); Stypes.dump (Some (outputprefix ^ ".annot")) end else begin - let bytecode = + let bytecode, required_globals = (typedtree, coercion) ++ Timings.(time (Transl sourcefile)) (Translmod.transl_implementation modulename) - ++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda ++ Timings.(accumulate_time (Generate sourcefile)) - (fun lambda -> - Simplif.simplify_lambda lambda + (fun { Lambda.code = lambda; required_globals } -> + print_if ppf Clflags.dump_rawlambda Printlambda.lambda lambda + ++ Simplif.simplify_lambda sourcefile ++ print_if ppf Clflags.dump_lambda Printlambda.lambda ++ Bytegen.compile_implementation modulename - ++ print_if ppf Clflags.dump_instr Printinstr.instrlist) + ++ print_if ppf Clflags.dump_instr Printinstr.instrlist + ++ fun bytecode -> bytecode, required_globals) in let objfile = outputprefix ^ ".cmo" in let oc = open_out_bin objfile in try bytecode ++ Timings.(accumulate_time (Generate sourcefile)) - (Emitcode.to_file oc modulename objfile); + (Emitcode.to_file oc modulename objfile ~required_globals); Warnings.check_fatal (); close_out oc; Stypes.dump (Some (outputprefix ^ ".annot")) @@ -109,7 +111,3 @@ let implementation ppf sourcefile outputprefix = with x -> Stypes.dump (Some (outputprefix ^ ".annot")); raise x - -let c_file name = - Location.input_name := name; - if Ccomp.compile_file name <> 0 then exit 2 diff --git a/driver/compile.mli b/driver/compile.mli index 2ae4f7a4..defc101b 100644 --- a/driver/compile.mli +++ b/driver/compile.mli @@ -19,4 +19,3 @@ open Format val interface: formatter -> string -> string -> unit val implementation: formatter -> string -> string -> unit -val c_file: string -> unit diff --git a/driver/compmisc.ml b/driver/compmisc.ml index 27efafd1..36a2b81c 100644 --- a/driver/compmisc.ml +++ b/driver/compmisc.ml @@ -27,10 +27,9 @@ let init_path ?(dir="") native = else if !Clflags.use_vmthreads && not native then "+vmthreads" :: !Clflags.include_dirs else - !last_include_dirs @ - !Clflags.include_dirs @ - !first_include_dirs + !Clflags.include_dirs in + let dirs = !last_include_dirs @ dirs @ !first_include_dirs in let exp_dirs = List.map (Misc.expand_directory Config.standard_library) dirs in Config.load_path := dir :: diff --git a/driver/compplugin.ml b/driver/compplugin.ml new file mode 100644 index 00000000..481692c1 --- /dev/null +++ b/driver/compplugin.ml @@ -0,0 +1,49 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* A table to avoid double linking of plugins, especially with OCAMLPARAM *) +let plugins = Hashtbl.create 13 + +let load plugin_name = + + let plugin_name = + try + Compdynlink.adapt_filename plugin_name + with Invalid_argument _ -> plugin_name + in + + let plugin_file = + if Filename.is_implicit plugin_name then + try + Compmisc.init_path !Clflags.native_code; + Misc.find_in_path !Config.load_path plugin_name + with Not_found -> + raise (Compdynlink.Error (Compdynlink.File_not_found plugin_name)) + else plugin_name + in + + if not (Hashtbl.mem plugins plugin_file) then begin + Compdynlink.loadfile plugin_file; + Hashtbl.add plugins plugin_file (); (* plugin loaded *) + end + +let () = + Location.register_error_of_exn (function + | Compdynlink.Error error -> + Some (Location.error ( + Printf.sprintf "%s while loading argument of -plugin" + (Compdynlink.error_message error))) + | _ -> None); + Compenv.load_plugin := load diff --git a/driver/compplugin.mli b/driver/compplugin.mli new file mode 100644 index 00000000..a1103f64 --- /dev/null +++ b/driver/compplugin.mli @@ -0,0 +1,16 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +val load : string -> unit diff --git a/driver/main.ml b/driver/main.ml index 3bfd8f3d..e9af202f 100644 --- a/driver/main.ml +++ b/driver/main.ml @@ -13,60 +13,13 @@ (* *) (**************************************************************************) -open Config open Clflags open Compenv -let process_interface_file ppf name = - let opref = output_prefix name in - Compile.interface ppf name opref; - if !make_package then objfiles := (opref ^ ".cmi") :: !objfiles - -let process_implementation_file ppf name = - let opref = output_prefix name in - Compile.implementation ppf name opref; - objfiles := (opref ^ ".cmo") :: !objfiles - -let process_file ppf name = - if Filename.check_suffix name ".ml" - || Filename.check_suffix name ".mlt" then - process_implementation_file ppf name - else if Filename.check_suffix name !Config.interface_suffix then - process_interface_file ppf name - else if Filename.check_suffix name ".cmo" - || Filename.check_suffix name ".cma" then - objfiles := name :: !objfiles - else if Filename.check_suffix name ".cmi" && !make_package then - objfiles := name :: !objfiles - else if Filename.check_suffix name ext_obj - || Filename.check_suffix name ext_lib then - ccobjs := name :: !ccobjs - else if Filename.check_suffix name ext_dll then - dllibs := name :: !dllibs - else if Filename.check_suffix name ".c" then begin - Compile.c_file name; - ccobjs := (Filename.chop_suffix (Filename.basename name) ".c" ^ ext_obj) - :: !ccobjs - end - else - raise(Arg.Bad("don't know what to do with " ^ name)) - let usage = "Usage: ocamlc \nOptions are:" -let ppf = Format.err_formatter - (* Error messages to standard error formatter *) -let anonymous filename = - readenv ppf (Before_compile filename); - process_file ppf filename;; - -let impl filename = - readenv ppf (Before_compile filename); - process_implementation_file ppf filename;; - -let intf filename = - readenv ppf (Before_compile filename); - process_interface_file ppf filename;; +let ppf = Format.err_formatter let show_config () = Config.print_config stdout; @@ -82,13 +35,13 @@ module Options = Main_args.Make_bytecomp_options (struct let _binannot = set binary_annotations let _c = set compile_only let _cc s = c_compiler := Some s - let _cclib s = ccobjs := Misc.rev_split_words s @ !ccobjs + let _cclib s = Compenv.defer (ProcessObjects (Misc.rev_split_words s)) let _ccopt s = first_ccopts := s :: !first_ccopts let _compat_32 = set bytecode_compatible_32 let _config = show_config let _custom = set custom_runtime let _no_check_prims = set no_check_prims - let _dllib s = dllibs := Misc.rev_split_words s @ !dllibs + let _dllib s = defer (ProcessDLLs (Misc.rev_split_words s)) let _dllpath s = dllpaths := !dllpaths @ [s] let _for_pack s = for_package := Some s let _g = set debug @@ -124,6 +77,7 @@ module Options = Main_args.Make_bytecomp_options (struct let _pack = set make_package let _pp s = preprocessor := Some s let _ppx s = first_ppx := s :: !first_ppx + let _plugin p = Compplugin.load p let _principal = set principal let _no_principal = unset principal let _rectypes = set recursive_types @@ -137,6 +91,8 @@ module Options = Main_args.Make_bytecomp_options (struct let _no_strict_formats = unset strict_formats let _thread = set use_threads let _vmthread = set use_vmthreads + let _unboxed_types = set unboxed_types + let _no_unboxed_types = unset unboxed_types let _unsafe = set fast let _unsafe_string = set unsafe_string let _use_prims s = use_prims := s @@ -169,6 +125,12 @@ let main () = try readenv ppf Before_args; Arg.parse Options.list anonymous usage; + Compenv.process_deferred_actions + (ppf, + Compile.implementation, + Compile.interface, + ".cmo", + ".cma"); readenv ppf Before_link; if List.length (List.filter (fun x -> !x) @@ -182,14 +144,15 @@ let main () = if !make_archive then begin Compmisc.init_path false; - Bytelibrarian.create_archive ppf (Compenv.get_objfiles ()) + Bytelibrarian.create_archive ppf + (Compenv.get_objfiles ~with_ocamlparam:false) (extract_output !output_name); Warnings.check_fatal (); end else if !make_package then begin Compmisc.init_path false; let extracted_output = extract_output !output_name in - let revd = get_objfiles () in + let revd = get_objfiles ~with_ocamlparam:false in Bytepackager.package_files ppf (Compmisc.initial_env ()) revd (extracted_output); Warnings.check_fatal (); @@ -212,7 +175,7 @@ let main () = default_output !output_name in Compmisc.init_path false; - Bytelink.link ppf (get_objfiles ()) target; + Bytelink.link ppf (get_objfiles ~with_ocamlparam:true) target; Warnings.check_fatal (); end; with x -> diff --git a/driver/main_args.ml b/driver/main_args.ml index ea89daf3..b40d3da5 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -228,7 +228,7 @@ let mk_keep_docs f = ;; let mk_no_keep_docs f = - "-keep-docs", Arg.Unit f, + "-no-keep-docs", Arg.Unit f, " Do not keep documentation strings in .cmi files (default)" ;; @@ -385,6 +385,11 @@ let mk_ppx f = " Pipe abstract syntax trees through preprocessor " ;; +let mk_plugin f = + "-plugin", Arg.String f, + " Load dynamic plugin " +;; + let mk_principal f = "-principal", Arg.Unit f, " Check principality of type inference" ;; @@ -418,7 +423,9 @@ let mk_S f = ;; let mk_safe_string f = - "-safe-string", Arg.Unit f, " Make strings immutable" + "-safe-string", Arg.Unit f, + if Config.safe_string then " Make strings immutable (default)" + else " Make strings immutable" ;; let mk_shared f = @@ -465,13 +472,30 @@ let mk_unbox_closures_factor f = Clflags.default_unbox_closures_factor ;; +let mk_unboxed_types f = + "-unboxed-types", Arg.Unit f, + " unannotated unboxable types will be unboxed" +;; + +let mk_no_unboxed_types f = + "-no-unboxed-types", Arg.Unit f, + " unannotated unboxable types will not be unboxed (default)" +;; + let mk_unsafe f = "-unsafe", Arg.Unit f, " Do not compile bounds checking on array and string access" ;; let mk_unsafe_string f = - "-unsafe-string", Arg.Unit f, " Make strings mutable (default)" + if Config.safe_string then + let err () = + raise (Arg.Bad "OCaml has been configured with -safe-string: \ + -unsafe-string is not available") + in + "-unsafe-string", Arg.Unit err, " (option not available)" + else + "-unsafe-string", Arg.Unit f, " Make strings mutable (default)" ;; let mk_use_runtime f = @@ -501,6 +525,10 @@ let mk__version f = "--version", Arg.Unit f, " Print version and exit" ;; +let mk_no_version f = + "-no-version", Arg.Unit f, " Do not print version at startup" +;; + let mk_vmthread f = "-vmthread", Arg.Unit f, " Generate code that supports the threads library with VM-level\n\ @@ -724,6 +752,8 @@ module type Common_options = sig val _no_strict_sequence : unit -> unit val _strict_formats : unit -> unit val _no_strict_formats : unit -> unit + val _unboxed_types : unit -> unit + val _no_unboxed_types : unit -> unit val _unsafe : unit -> unit val _unsafe_string : unit -> unit val _version : unit -> unit @@ -767,6 +797,7 @@ module type Compiler_options = sig val _output_obj : unit -> unit val _output_complete_obj : unit -> unit val _pack : unit -> unit + val _plugin : string -> unit val _pp : string -> unit val _principal : unit -> unit val _no_principal : unit -> unit @@ -785,6 +816,18 @@ module type Compiler_options = sig end ;; +module type Toplevel_options = sig + include Common_options + val _init : string -> unit + val _noinit : unit -> unit + val _no_version : unit -> unit + val _noprompt : unit -> unit + val _nopromptcont : unit -> unit + val _plugin : string -> unit + val _stdin : unit -> unit +end +;; + module type Bytecomp_options = sig include Common_options include Compiler_options @@ -803,13 +846,7 @@ module type Bytecomp_options = sig end;; module type Bytetop_options = sig - include Common_options - val _init : string -> unit - val _noinit : unit -> unit - val _noprompt : unit -> unit - val _nopromptcont : unit -> unit - val _stdin : unit -> unit - + include Toplevel_options val _dinstr : unit -> unit end;; @@ -875,14 +912,10 @@ module type Optcomp_options = sig end;; module type Opttop_options = sig - include Common_options + include Toplevel_options include Optcommon_options - val _init : string -> unit - val _noinit : unit -> unit - val _noprompt : unit -> unit - val _nopromptcont : unit -> unit + val _verbose : unit -> unit val _S : unit -> unit - val _stdin : unit -> unit end;; module type Ocamldoc_options = sig @@ -957,6 +990,7 @@ struct mk_pack_byt F._pack; mk_pp F._pp; mk_ppx F._ppx; + mk_plugin F._plugin; mk_principal F._principal; mk_no_principal F._no_principal; mk_rectypes F._rectypes; @@ -969,6 +1003,8 @@ struct mk_strict_formats F._strict_formats; mk_no_strict_formats F._no_strict_formats; mk_thread F._thread; + mk_unboxed_types F._unboxed_types; + mk_no_unboxed_types F._no_unboxed_types; mk_unsafe F._unsafe; mk_unsafe_string F._unsafe_string; mk_use_runtime F._use_runtime; @@ -1016,6 +1052,7 @@ struct mk_nostdlib F._nostdlib; mk_open F._open; mk_ppx F._ppx; + mk_plugin F._plugin; mk_principal F._principal; mk_no_principal F._no_principal; mk_rectypes F._rectypes; @@ -1027,10 +1064,13 @@ struct mk_no_strict_sequence F._no_strict_sequence; mk_strict_formats F._strict_formats; mk_no_strict_formats F._no_strict_formats; + mk_unboxed_types F._unboxed_types; + mk_no_unboxed_types F._no_unboxed_types; mk_unsafe F._unsafe; mk_unsafe_string F._unsafe_string; mk_version F._version; mk__version F._version; + mk_no_version F._no_version; mk_vnum F._vnum; mk_w F._w; mk_warn_error F._warn_error; @@ -1108,6 +1148,7 @@ struct mk_output_complete_obj F._output_complete_obj; mk_p F._p; mk_pack_opt F._pack; + mk_plugin F._plugin; mk_pp F._pp; mk_ppx F._ppx; mk_principal F._principal; @@ -1129,6 +1170,8 @@ struct mk_unbox_closures F._unbox_closures; mk_unbox_closures_factor F._unbox_closures_factor; mk_inline_max_unroll F._inline_max_unroll; + mk_unboxed_types F._unboxed_types; + mk_no_unboxed_types F._no_unboxed_types; mk_unsafe F._unsafe; mk_unsafe_string F._unsafe_string; mk_v F._v; @@ -1209,6 +1252,7 @@ module Make_opttop_options (F : Opttop_options) = struct mk_o2 F._o2; mk_o3 F._o3; mk_open F._open; + mk_plugin F._plugin; mk_ppx F._ppx; mk_principal F._principal; mk_no_principal F._no_principal; @@ -1225,10 +1269,14 @@ module Make_opttop_options (F : Opttop_options) = struct mk_no_strict_formats F._no_strict_formats; mk_unbox_closures F._unbox_closures; mk_unbox_closures_factor F._unbox_closures_factor; + mk_unboxed_types F._unboxed_types; + mk_no_unboxed_types F._no_unboxed_types; mk_unsafe F._unsafe; mk_unsafe_string F._unsafe_string; + mk_verbose F._verbose; mk_version F._version; mk__version F._version; + mk_no_version F._no_version; mk_vnum F._vnum; mk_w F._w; mk_warn_error F._warn_error; @@ -1293,6 +1341,8 @@ struct mk_strict_formats F._strict_formats; mk_no_strict_formats F._no_strict_formats; mk_thread F._thread; + mk_unboxed_types F._unboxed_types; + mk_no_unboxed_types F._no_unboxed_types; mk_unsafe_string F._unsafe_string; mk_v F._v; mk_verbose F._verbose; diff --git a/driver/main_args.mli b/driver/main_args.mli index 49de50d5..b5b0eaae 100644 --- a/driver/main_args.mli +++ b/driver/main_args.mli @@ -39,6 +39,8 @@ module type Common_options = sig val _no_strict_sequence : unit -> unit val _strict_formats : unit -> unit val _no_strict_formats : unit -> unit + val _unboxed_types : unit -> unit + val _no_unboxed_types : unit -> unit val _unsafe : unit -> unit val _unsafe_string : unit -> unit val _version : unit -> unit @@ -82,6 +84,7 @@ module type Compiler_options = sig val _output_obj : unit -> unit val _output_complete_obj : unit -> unit val _pack : unit -> unit + val _plugin : string -> unit val _pp : string -> unit val _principal : unit -> unit val _no_principal : unit -> unit @@ -100,6 +103,18 @@ module type Compiler_options = sig end ;; +module type Toplevel_options = sig + include Common_options + val _init : string -> unit + val _noinit : unit -> unit + val _no_version : unit -> unit + val _noprompt : unit -> unit + val _nopromptcont : unit -> unit + val _plugin : string -> unit + val _stdin : unit -> unit +end +;; + module type Bytecomp_options = sig include Common_options include Compiler_options @@ -118,13 +133,7 @@ module type Bytecomp_options = sig end;; module type Bytetop_options = sig - include Common_options - val _init : string -> unit - val _noinit : unit -> unit - val _noprompt : unit -> unit - val _nopromptcont : unit -> unit - val _stdin : unit -> unit - + include Toplevel_options val _dinstr : unit -> unit end;; @@ -190,14 +199,10 @@ module type Optcomp_options = sig end;; module type Opttop_options = sig - include Common_options + include Toplevel_options include Optcommon_options - val _init : string -> unit - val _noinit : unit -> unit - val _noprompt : unit -> unit - val _nopromptcont : unit -> unit + val _verbose : unit -> unit val _S : unit -> unit - val _stdin : unit -> unit end;; module type Ocamldoc_options = sig diff --git a/driver/optcompile.ml b/driver/optcompile.ml index 00e424bc..991b9f52 100644 --- a/driver/optcompile.ml +++ b/driver/optcompile.ml @@ -35,7 +35,7 @@ let interface ppf sourcefile outputprefix = let ast = Pparse.parse_interface ~tool_name ppf sourcefile in if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast; if !Clflags.dump_source then fprintf ppf "%a@." Pprintast.signature ast; - let tsg = Typemod.type_interface initial_env ast in + let tsg = Typemod.type_interface sourcefile initial_env ast in if !Clflags.dump_typedtree then fprintf ppf "%a@." Printtyped.interface tsg; let sg = tsg.sig_type in if !Clflags.print_types then @@ -63,7 +63,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 ~backend = +let implementation ~backend ppf sourcefile outputprefix = let source_provenance = Timings.File sourcefile in Compmisc.init_path true; let modulename = module_of_filename ppf sourcefile outputprefix in @@ -93,10 +93,12 @@ let implementation ppf sourcefile outputprefix ~backend = (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 + ++ Timings.time (Timings.Generate sourcefile) + (fun { Lambda.module_ident; main_module_block_size; + required_globals; code } -> + ((module_ident, main_module_block_size), code) + +++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda + +++ Simplif.simplify_lambda sourcefile +++ print_if ppf Clflags.dump_lambda Printlambda.lambda ++ (fun ((module_ident, size), lam) -> Middle_end.middle_end ppf ~source_provenance @@ -107,7 +109,7 @@ let implementation ppf sourcefile outputprefix ~backend = ~backend ~module_initializer:lam) ++ Asmgen.compile_implementation_flambda ~source_provenance - outputprefix ~backend ppf; + outputprefix ~required_globals ~backend ppf; Compilenv.save_unit_info cmxfile) end else begin @@ -117,9 +119,10 @@ let implementation ppf sourcefile outputprefix ~backend = (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 } + (fun program -> + { program with + Lambda.code = Simplif.simplify_lambda sourcefile + program.Lambda.code } ++ print_if ppf Clflags.dump_lambda Printlambda.program ++ Asmgen.compile_implementation_clambda ~source_provenance outputprefix ppf; @@ -135,6 +138,3 @@ let implementation ppf sourcefile outputprefix ~backend = remove_file objfile; remove_file cmxfile; raise x - -let c_file name = - if Ccomp.compile_file name <> 0 then exit 2 diff --git a/driver/optcompile.mli b/driver/optcompile.mli index 8c6865da..3f308138 100644 --- a/driver/optcompile.mli +++ b/driver/optcompile.mli @@ -19,11 +19,9 @@ open Format val interface: formatter -> string -> string -> unit -val implementation - : formatter +val implementation: + backend:(module Backend_intf.S) + -> 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 8d1d3dd3..2c6d60e9 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -13,7 +13,6 @@ (* *) (**************************************************************************) -open Config open Clflags open Compenv @@ -35,59 +34,8 @@ module Backend = struct 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; - if !make_package then objfiles := (opref ^ ".cmi") :: !objfiles - -let process_implementation_file ppf name = - let opref = output_prefix name in - Optcompile.implementation ppf name opref ~backend; - objfiles := (opref ^ ".cmx") :: !objfiles - -let cmxa_present = ref false;; - -let process_file ppf name = - if Filename.check_suffix name ".ml" - || Filename.check_suffix name ".mlt" then - process_implementation_file ppf name - else if Filename.check_suffix name !Config.interface_suffix then - process_interface_file ppf name - else if Filename.check_suffix name ".cmx" then - objfiles := name :: !objfiles - else if Filename.check_suffix name ".cmxa" then begin - cmxa_present := true; - objfiles := name :: !objfiles - end else if Filename.check_suffix name ".cmi" && !make_package then - objfiles := name :: !objfiles - else if Filename.check_suffix name ext_obj - || Filename.check_suffix name ext_lib then - ccobjs := name :: !ccobjs - else if Filename.check_suffix name ".c" then begin - Optcompile.c_file name; - ccobjs := (Filename.chop_suffix (Filename.basename name) ".c" ^ ext_obj) - :: !ccobjs - end - else - raise(Arg.Bad("don't know what to do with " ^ name)) - let usage = "Usage: ocamlopt \nOptions are:" -let ppf = Format.err_formatter - -(* Error messages to standard error formatter *) -let anonymous filename = - readenv ppf (Before_compile filename); - process_file ppf filename;; - -let impl filename = - readenv ppf (Before_compile filename); - process_implementation_file ppf filename;; - -let intf filename = - readenv ppf (Before_compile filename); - process_interface_file ppf filename;; - let show_config () = Config.print_config stdout; exit 0; @@ -103,7 +51,7 @@ module Options = Main_args.Make_optcomp_options (struct let _binannot = set binary_annotations let _c = set compile_only let _cc s = c_compiler := Some s - let _cclib s = ccobjs := Misc.rev_split_words s @ !ccobjs + let _cclib s = defer (ProcessObjects (Misc.rev_split_words s)) let _ccopt s = first_ccopts := s :: !first_ccopts let _clambda_checks () = clambda_checks := true let _compact = clear optimize_for_speed @@ -114,39 +62,48 @@ module Options = Main_args.Make_optcomp_options (struct let _I dir = include_dirs := dir :: !include_dirs let _impl = impl let _inline spec = - Float_arg_helper.parse spec ~update:inline_threshold - ~help_text:"Syntax: -inline | =[,...]" + Float_arg_helper.parse spec + "Syntax: -inline | =[,...]" inline_threshold let _inline_toplevel spec = - Int_arg_helper.parse spec ~update:inline_toplevel_threshold - ~help_text:"Syntax: -inline-toplevel | =[,...]" + Int_arg_helper.parse spec + "Syntax: -inline-toplevel | =[,...]" + inline_toplevel_threshold let _inlining_report () = inlining_report := true let _dump_pass pass = set_dumped_pass pass true let _rounds n = simplify_rounds := Some n let _inline_max_unroll spec = - Int_arg_helper.parse spec ~update:inline_max_unroll - ~help_text:"Syntax: -inline-max-unroll | =[,...]" + Int_arg_helper.parse spec + "Syntax: -inline-max-unroll | =[,...]" + inline_max_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 | =[,...]" + Int_arg_helper.parse spec + "Syntax: -inline-call-cost | =[,...]" + inline_call_cost let _inline_alloc_cost spec = - Int_arg_helper.parse spec ~update:inline_alloc_cost - ~help_text:"Syntax: -inline-alloc-cost | =[,...]" + Int_arg_helper.parse spec + "Syntax: -inline-alloc-cost | =[,...]" + inline_alloc_cost let _inline_prim_cost spec = - Int_arg_helper.parse spec ~update:inline_prim_cost - ~help_text:"Syntax: -inline-prim-cost | =[,...]" + Int_arg_helper.parse spec + "Syntax: -inline-prim-cost | =[,...]" + inline_prim_cost let _inline_branch_cost spec = - Int_arg_helper.parse spec ~update:inline_branch_cost - ~help_text:"Syntax: -inline-branch-cost | =[,...]" + Int_arg_helper.parse spec + "Syntax: -inline-branch-cost | =[,...]" + inline_branch_cost let _inline_indirect_cost spec = - Int_arg_helper.parse spec ~update:inline_indirect_cost - ~help_text:"Syntax: -inline-indirect-cost | =[,...]" + Int_arg_helper.parse spec + "Syntax: -inline-indirect-cost | =[,...]" + inline_indirect_cost let _inline_lifting_benefit spec = - Int_arg_helper.parse spec ~update:inline_lifting_benefit - ~help_text:"Syntax: -inline-lifting-benefit | =[,...]" + Int_arg_helper.parse spec + "Syntax: -inline-lifting-benefit | =[,...]" + inline_lifting_benefit let _inline_branch_factor spec = - Float_arg_helper.parse spec ~update:inline_branch_factor - ~help_text:"Syntax: -inline-branch-factor | =[,...]" + Float_arg_helper.parse spec + "Syntax: -inline-branch-factor | =[,...]" + inline_branch_factor let _intf = intf let _intf_suffix s = Config.interface_suffix := s let _keep_docs = set keep_docs @@ -156,8 +113,9 @@ module Options = Main_args.Make_optcomp_options (struct let _labels = clear classic let _linkall = set link_everything let _inline_max_depth spec = - Int_arg_helper.parse spec ~update:inline_max_depth - ~help_text:"Syntax: -inline-max-depth | =[,...]" + Int_arg_helper.parse spec + "Syntax: -inline-max-depth | =[,...]" + inline_max_depth let _alias_deps = clear transparent_modules let _no_alias_deps = set transparent_modules let _app_funct = set applicative_functors @@ -195,6 +153,7 @@ module Options = Main_args.Make_optcomp_options (struct set output_c_object (); set output_complete_object () let _p = set gprofile let _pack = set make_package + let _plugin p = Compplugin.load p let _pp s = preprocessor := Some s let _ppx s = first_ppx := s :: !first_ppx let _principal = set principal @@ -214,6 +173,8 @@ module Options = Main_args.Make_optcomp_options (struct let _thread = set use_threads let _unbox_closures = set unbox_closures let _unbox_closures_factor f = unbox_closures_factor := f + let _unboxed_types = set unboxed_types + let _no_unboxed_types = clear unboxed_types let _unsafe = set fast let _unsafe_string = set unsafe_string let _v () = print_version_and_library "native-code compiler" @@ -271,6 +232,12 @@ let main () = try readenv ppf Before_args; Arg.parse (Arch.command_line_options @ Options.list) anonymous usage; + Compenv.process_deferred_actions + (ppf, + Optcompile.implementation ~backend, + Optcompile.interface, + ".cmx", + ".cmxa"); readenv ppf Before_link; if List.length (List.filter (fun x -> !x) @@ -279,24 +246,22 @@ let main () = then fatal "Please specify at most one of -pack, -a, -shared, -c, -output-obj"; if !make_archive then begin - if !cmxa_present then - fatal "Option -a cannot be used with .cmxa input files."; Compmisc.init_path true; let target = extract_output !output_name in - Asmlibrarian.create_archive (get_objfiles ()) target; + Asmlibrarian.create_archive (get_objfiles ~with_ocamlparam:false) target; Warnings.check_fatal (); end else if !make_package then begin Compmisc.init_path true; let target = extract_output !output_name in Asmpackager.package_files ppf (Compmisc.initial_env ()) - (get_objfiles ()) target ~backend; + (get_objfiles ~with_ocamlparam:false) target ~backend; Warnings.check_fatal (); end else if !shared then begin Compmisc.init_path true; let target = extract_output !output_name in - Asmlink.link_shared ppf (get_objfiles ()) target; + Asmlink.link_shared ppf (get_objfiles ~with_ocamlparam:false) target; Warnings.check_fatal (); end else if not !compile_only && !objfiles <> [] then begin @@ -316,7 +281,7 @@ let main () = default_output !output_name in Compmisc.init_path true; - Asmlink.link ppf (get_objfiles ()) target; + Asmlink.link ppf (get_objfiles ~with_ocamlparam:true) target; Warnings.check_fatal (); end; with x -> diff --git a/driver/pparse.ml b/driver/pparse.ml index 527291ed..5fbaa91e 100644 --- a/driver/pparse.ml +++ b/driver/pparse.ml @@ -47,20 +47,26 @@ let remove_preprocessed inputfile = None -> () | Some _ -> Misc.remove_file inputfile +type 'a ast_kind = +| Structure : Parsetree.structure ast_kind +| Signature : Parsetree.signature ast_kind + +let magic_of_kind : type a . a ast_kind -> string = function + | Structure -> Config.ast_impl_magic_number + | Signature -> Config.ast_intf_magic_number (* Note: some of the functions here should go to Ast_mapper instead, which would encapsulate the "binary AST" protocol. *) -let write_ast magic ast = - let fn = Filename.temp_file "camlppx" "" in +let write_ast (type a) (kind : a ast_kind) fn (ast : a) = let oc = open_out_bin fn in - output_string oc magic; - output_value oc !Location.input_name; - output_value oc ast; - close_out oc; - fn + output_string oc (magic_of_kind kind); + output_value oc (!Location.input_name : string); + output_value oc (ast : a); + close_out oc -let apply_rewriter magic fn_in ppx = +let apply_rewriter kind fn_in ppx = + let magic = magic_of_kind kind in let fn_out = Filename.temp_file "camlppx" "" in let comm = Printf.sprintf "%s %s %s" ppx (Filename.quote fn_in) (Filename.quote fn_out) @@ -84,13 +90,14 @@ let apply_rewriter magic fn_in ppx = end; fn_out -let read_ast magic fn = +let read_ast (type a) (kind : a ast_kind) fn : a = let ic = open_in_bin fn in try + let magic = magic_of_kind kind in let buffer = really_input_string ic (String.length magic) in assert(buffer = magic); (* already checked by apply_rewriter *) - Location.input_name := input_value ic; - let ast = input_value ic in + Location.input_name := (input_value ic : string); + let ast = (input_value ic : a) in close_in ic; Misc.remove_file fn; ast @@ -99,34 +106,37 @@ let read_ast magic fn = Misc.remove_file fn; raise exn -let rewrite magic ast ppxs = - read_ast magic - (List.fold_left (apply_rewriter magic) (write_ast magic ast) - (List.rev ppxs)) +let rewrite kind ppxs ast = + let fn = Filename.temp_file "camlppx" "" in + write_ast kind fn ast; + let fn = List.fold_left (apply_rewriter kind) fn (List.rev ppxs) in + read_ast kind fn let apply_rewriters_str ?(restore = true) ~tool_name ast = match !Clflags.all_ppx with | [] -> ast | ppxs -> - let ast = Ast_mapper.add_ppx_context_str ~tool_name ast in - let ast = rewrite Config.ast_impl_magic_number ast ppxs in - Ast_mapper.drop_ppx_context_str ~restore ast + ast + |> Ast_mapper.add_ppx_context_str ~tool_name + |> rewrite Structure ppxs + |> Ast_mapper.drop_ppx_context_str ~restore let apply_rewriters_sig ?(restore = true) ~tool_name ast = match !Clflags.all_ppx with | [] -> ast | ppxs -> - let ast = Ast_mapper.add_ppx_context_sig ~tool_name ast in - let ast = rewrite Config.ast_intf_magic_number ast ppxs in - Ast_mapper.drop_ppx_context_sig ~restore ast - -let apply_rewriters ?restore ~tool_name magic ast = - if magic = Config.ast_impl_magic_number then - Obj.magic (apply_rewriters_str ?restore ~tool_name (Obj.magic ast)) - else if magic = Config.ast_intf_magic_number then - Obj.magic (apply_rewriters_sig ?restore ~tool_name (Obj.magic ast)) - else - assert false + ast + |> Ast_mapper.add_ppx_context_sig ~tool_name + |> rewrite Signature ppxs + |> Ast_mapper.drop_ppx_context_sig ~restore + +let apply_rewriters ?restore ~tool_name + (type a) (kind : a ast_kind) (ast : a) : a = + match kind with + | Structure -> + apply_rewriters_str ?restore ~tool_name ast + | Signature -> + apply_rewriters_sig ?restore ~tool_name ast (* Parse a file or get a dumped syntax tree from it *) @@ -148,7 +158,14 @@ let open_and_check_magic inputfile ast_magic = in (ic, is_ast_file) -let file_aux ppf ~tool_name inputfile parse_fun invariant_fun ast_magic = +let parse (type a) (kind : a ast_kind) lexbuf : a = + match kind with + | Structure -> Parse.implementation lexbuf + | Signature -> Parse.interface lexbuf + +let file_aux ppf ~tool_name inputfile (type a) parse_fun invariant_fun + (kind : a ast_kind) = + let ast_magic = magic_of_kind kind in let (ic, is_ast_file) = open_and_check_magic inputfile ast_magic in let ast = try @@ -157,8 +174,8 @@ let file_aux ppf ~tool_name inputfile parse_fun invariant_fun ast_magic = (* FIXME make this a proper warning *) fprintf ppf "@[Warning: %s@]@." "option -unsafe used with a preprocessor returning a syntax tree"; - Location.input_name := input_value ic; - input_value ic + Location.input_name := (input_value ic : string); + (input_value ic : a) end else begin seek_in ic 0; Location.input_name := inputfile; @@ -169,12 +186,12 @@ let file_aux ppf ~tool_name inputfile parse_fun invariant_fun ast_magic = with x -> close_in ic; raise x in close_in ic; - let ast = apply_rewriters ~restore:false ~tool_name ast_magic ast in + let ast = apply_rewriters ~restore:false ~tool_name kind 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 file ppf ~tool_name inputfile parse_fun ast_kind = + file_aux ppf ~tool_name inputfile parse_fun ignore ast_kind let report_error ppf = function | CannotRun cmd -> @@ -191,25 +208,30 @@ let () = | _ -> None ) -let parse_all ~tool_name parse_fun invariant_fun magic ppf sourcefile = +let parse_file ~tool_name invariant_fun apply_hooks kind ppf sourcefile = Location.input_name := sourcefile; let inputfile = preprocess sourcefile in let ast = - try file_aux ppf ~tool_name inputfile parse_fun invariant_fun magic + let parse_fun = Timings.(time (Parsing sourcefile)) (parse kind) in + try file_aux ppf ~tool_name inputfile parse_fun invariant_fun kind with exn -> remove_preprocessed inputfile; raise exn in remove_preprocessed inputfile; + let ast = apply_hooks { Misc.sourcefile } ast in ast +module ImplementationHooks = Misc.MakeHooks(struct + type t = Parsetree.structure + end) +module InterfaceHooks = Misc.MakeHooks(struct + type t = Parsetree.signature + end) + 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 + parse_file ~tool_name Ast_invariants.structure + ImplementationHooks.apply_hooks Structure 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 + parse_file ~tool_name Ast_invariants.signature + InterfaceHooks.apply_hooks Signature ppf sourcefile diff --git a/driver/pparse.mli b/driver/pparse.mli index 4ccb0925..86d805b8 100644 --- a/driver/pparse.mli +++ b/driver/pparse.mli @@ -23,10 +23,19 @@ exception Error of error val preprocess : string -> string val remove_preprocessed : string -> unit -val file : - formatter -> tool_name:string -> string -> (Lexing.lexbuf -> 'a) -> string -> - 'a -val apply_rewriters: ?restore:bool -> tool_name:string -> string -> 'a -> 'a + +type 'a ast_kind = +| Structure : Parsetree.structure ast_kind +| Signature : Parsetree.signature ast_kind + +val read_ast : 'a ast_kind -> string -> 'a +val write_ast : 'a ast_kind -> string -> 'a -> unit + +val file : formatter -> tool_name:string -> string -> + (Lexing.lexbuf -> 'a) -> 'a ast_kind -> 'a + +val apply_rewriters: ?restore:bool -> tool_name:string -> + 'a ast_kind -> 'a -> 'a (** If [restore = true] (the default), cookies set by external rewriters will be kept for later calls. *) @@ -37,7 +46,6 @@ val apply_rewriters_sig: ?restore:bool -> tool_name:string -> Parsetree.signature -> Parsetree.signature - val report_error : formatter -> error -> unit @@ -49,4 +57,6 @@ val parse_interface: (* [call_external_preprocessor sourcefile pp] *) val call_external_preprocessor : string -> string -> string val open_and_check_magic : string -> string -> in_channel * bool -val read_ast : string -> string -> 'a + +module ImplementationHooks : Misc.HookSig with type t = Parsetree.structure +module InterfaceHooks : Misc.HookSig with type t = Parsetree.signature diff --git a/emacs/caml-types.el b/emacs/caml-types.el index 7ecc5d4b..306fa5c5 100644 --- a/emacs/caml-types.el +++ b/emacs/caml-types.el @@ -21,6 +21,12 @@ (require 'caml-xemacs) (require 'caml-emacs))) +(defun caml-types-feedback (info format) + "Displays INFO using the given FORMAT." + (message (format format info)) + (with-current-buffer caml-types-buffer + (erase-buffer) + (insert info))) (defvar caml-types-build-dirs '("_build" "_obuild") "List of possible compilation directories created by build systems. @@ -65,8 +71,7 @@ Their format is: and second nums. The current list of keywords is: -type call ident" -) +type call ident") (defvar caml-types-position-re nil) @@ -127,33 +132,33 @@ type call ident" (make-variable-buffer-local 'caml-types-annotation-date) (defvar caml-types-buffer-name "*caml-types*" - "Name of buffer for displaying caml types") + "Name of buffer for displaying caml types.") (defvar caml-types-buffer nil - "buffer for displaying caml types") + "Buffer for displaying caml types.") (defun caml-types-show-type (arg) "Show the type of expression or pattern at point. - The smallest expression or pattern that contains point is - temporarily highlighted. Its type is highlighted in the .annot - file and the mark is set to the beginning of the type. - The type is also displayed in the mini-buffer. - - Hints on using the type display: - . If you want the type of an identifier, put point within any - occurrence of this identifier. - . If you want the result type of a function application, put point - at the first space after the function name. - . If you want the type of a list, put point on a bracket, on a - semicolon, or on the :: constructor. - . Even if type checking fails, you can still look at the types - in the file, up to where the type checker failed. + +The smallest expression or pattern that contains point is +temporarily highlighted. Its type is highlighted in the .annot +file and the mark is set to the beginning of the type. The type +is also displayed in the mini-buffer. + +Hints on using the type display: +. If you want the type of an identifier, put point within any +occurrence of this identifier. +. If you want the result type of a function application, put +point at the first space after the function name. . If you want +the type of a list, put point on a bracket, on a semicolon, or on +the :: constructor. +. Even if type checking fails, you can still look at the types +in the file, up to where the type checker failed. Types are also displayed in the buffer *caml-types*, which is displayed when the command is called with Prefix argument 4. See also `caml-types-explore' for exploration by mouse dragging. -See `caml-types-location-re' for annotation file format. -" +See `caml-types-location-re' for annotation file format." (interactive "p") (let* ((target-buf (current-buffer)) (target-file (file-name-nondirectory (buffer-file-name))) @@ -175,31 +180,26 @@ See `caml-types-location-re' for annotation file format. (right (caml-types-get-pos target-buf (elt node 1))) (type (cdr (assoc "type" (elt node 2))))) (move-overlay caml-types-expr-ovl left right target-buf) - (with-current-buffer caml-types-buffer - (erase-buffer) - (insert type) - (message (format "type: %s" type))) - )))) + (caml-types-feedback type "type: %s"))))) (if (and (= arg 4) (not (window-live-p (get-buffer-window caml-types-buffer)))) (display-buffer caml-types-buffer)) (unwind-protect (caml-sit-for 60) - (delete-overlay caml-types-expr-ovl) - ))) + (delete-overlay caml-types-expr-ovl)))) (defun caml-types-show-call (arg) "Show the kind of call at point. - The smallest function call that contains point is - temporarily highlighted. Its kind is highlighted in the .annot - file and the mark is set to the beginning of the kind. - The kind is also displayed in the mini-buffer. + +The smallest function call that contains point is temporarily +highlighted. Its kind is highlighted in the .annot file and the +mark is set to the beginning of the kind. The kind is also +displayed in the mini-buffer. The kind is also displayed in the buffer *caml-types*, which is displayed when the command is called with Prefix argument 4. -See `caml-types-location-re' for annotation file format. -" +See `caml-types-location-re' for annotation file format." (interactive "p") (let* ((target-buf (current-buffer)) (target-file (file-name-nondirectory (buffer-file-name))) @@ -221,31 +221,26 @@ See `caml-types-location-re' for annotation file format. (right (caml-types-get-pos target-buf (elt node 1))) (kind (cdr (assoc "call" (elt node 2))))) (move-overlay caml-types-expr-ovl left right target-buf) - (with-current-buffer caml-types-buffer - (erase-buffer) - (insert kind) - (message (format "%s call" kind))) - )))) + (caml-types-feedback kind))))) (if (and (= arg 4) (not (window-live-p (get-buffer-window caml-types-buffer)))) (display-buffer caml-types-buffer)) (unwind-protect (caml-sit-for 60) - (delete-overlay caml-types-expr-ovl) - ))) + (delete-overlay caml-types-expr-ovl)))) (defun caml-types-show-ident (arg) "Show the binding of identifier at point. - The identifier that contains point is - temporarily highlighted. Its binding is highlighted in the .annot - file and the mark is set to the beginning of the binding. - The binding is also displayed in the mini-buffer. + +The identifier that contains point is temporarily highlighted. +Its binding is highlighted in the .annot file and the mark is set +to the beginning of the binding. The binding is also displayed +in the mini-buffer. The binding is also displayed in the buffer *caml-types*, which is displayed when the command is called with Prefix argument 4. -See `caml-types-location-re' for annotation file format. -" +See `caml-types-location-re' for annotation file format." (interactive "p") (let* ((target-buf (current-buffer)) (target-file (file-name-nondirectory (buffer-file-name))) @@ -321,11 +316,7 @@ See `caml-types-location-re' for annotation file format. var-name l-line (- l-cnum l-bol)))))) ((string-match external-re kind) (let ((fullname (match-string 1 kind))) - (with-current-buffer caml-types-buffer - (erase-buffer) - (insert fullname) - (message (format "external ident: %s" fullname))))))) - )))) + (caml-types-feedback fullname "external ident: %s"))))))))) (if (and (= arg 4) (not (window-live-p (get-buffer-window caml-types-buffer)))) (display-buffer caml-types-buffer)) @@ -333,8 +324,7 @@ See `caml-types-location-re' for annotation file format. (caml-sit-for 60) (delete-overlay caml-types-expr-ovl) (delete-overlay caml-types-def-ovl) - (delete-overlay caml-types-scope-ovl) - ))) + (delete-overlay caml-types-scope-ovl)))) (defun caml-types-preprocess (target-path) (let* ((type-path (caml-types-locate-type-file target-path)) @@ -357,14 +347,13 @@ See `caml-types-location-re' for annotation file format. (setq caml-types-annotation-tree tree caml-types-annotation-date type-date) (kill-buffer type-buf) - (message "done")) - ))) + (message "done"))))) (defun caml-types-parent-dir (d) (file-name-directory (directory-file-name d))) (defun caml-types-locate-type-file (target-path) - "Given the path to an OCaml file, this function tries to locate -and return the corresponding .annot file." + "Given the path to an OCaml file, try to locate and return the +corresponding .annot file." (let ((sibling (concat (file-name-sans-extension target-path) ".annot"))) (if (file-exists-p sibling) sibling @@ -414,8 +403,7 @@ and return the corresponding .annot file." (if (re-search-forward "^[a-z\"]" () t) (forward-char -1) (goto-char (point-max))) - (looking-at "[a-z]") -) + (looking-at "[a-z]")) ; tree of intervals ; each node is a vector @@ -456,7 +444,7 @@ and return the corresponding .annot file." accu))) (setq stack (cons node stack)))))) (if (null stack) - (error "no annotations found for this source file") + (error "No annotations found for this source file") (let* ((left-pos (elt (car (last stack)) 0)) (right-pos (elt (car stack) 1))) (if (null (cdr stack)) @@ -594,15 +582,12 @@ and return the corresponding .annot file." (unless (verify-visited-file-modtime buf) (if (buffer-modified-p buf) (find-file-noselect name) - (with-current-buffer buf (revert-buffer t t))) - )) + (with-current-buffer buf (revert-buffer t t))))) ((and (file-readable-p name) (setq buf (find-file-noselect name))) - (with-current-buffer buf (toggle-read-only 1)) - ) + (with-current-buffer buf (toggle-read-only 1))) (t - (error (format "Can't read the annotation file `%s'" name))) - ) + (error (format "Can't read the annotation file `%s'" name)))) buf)) (defun caml-types-mouse-ignore (event) @@ -624,8 +609,7 @@ The function uses two overlays. . One overlay delimits the largest region whose all subnodes are well-typed. . Another overlay delimits the current node under the mouse (whose type - annotation is being displayed). -" + annotation is being displayed)." (interactive "e") (set-buffer (window-buffer (caml-event-window event))) (let* ((target-buf (current-buffer)) @@ -638,8 +622,7 @@ The function uses two overlays. target-tree (speed 100) (last-time (caml-types-time)) - (original-event event) - ) + (original-event event)) (select-window window) (unwind-protect (progn @@ -665,15 +648,13 @@ The function uses two overlays. (top (nth 1 win)) (bottom (- (nth 3 win) 1)) mouse - time - ) + time) (while (and (caml-sit-for 0 (/ 500 speed)) (setq time (caml-types-time)) (> (- time last-time) (/ 500 speed)) (setq mouse (caml-mouse-vertical-position)) - (or (< mouse top) (>= mouse bottom)) - ) + (or (< mouse top) (>= mouse bottom))) (setq last-time time) (cond ((< mouse top) @@ -685,10 +666,8 @@ The function uses two overlays. (setq speed (+ 1 (- mouse bottom))) (condition-case nil (scroll-up 1) - (error (message "End of buffer!")))) - ) - (setq speed (* speed speed)) - ))) + (error (message "End of buffer!"))))) + (setq speed (* speed speed))))) ;; main action, when the motion is inside the window ;; or on orginal button down event ((or (caml-mouse-movement-p event) @@ -737,23 +716,15 @@ The function uses two overlays. (setq limits (caml-types-find-interval target-buf target-pos node) - type (cdr (assoc "type" (elt node 2)))) - )) - ) + type (cdr (assoc "type" (elt node 2))))))) (setq mes (format "type: %s" type)) - (insert type) - )) - (message mes) - ) - ) + (insert type))) + (message mes))) ;; we read next event, unless it is nil, and loop back. - (if event (setq event (caml-read-event))) - ) - ) + (if event (setq event (caml-read-event))))) ;; delete overlays at end of exploration (delete-overlay caml-types-expr-ovl) - (delete-overlay caml-types-typed-ovl) - )) + (delete-overlay caml-types-typed-ovl))) ;; When an error occurs, the mouse release event has not been read. ;; We could wait for mouse release to prevent execution of ;; a binding of mouse release, such as cut or paste. @@ -763,8 +734,7 @@ The function uses two overlays. ;; Not sure it is robust to loop for mouse release after an error ;; occured, as is done for exploration. ;; So far, we just ignore next event. (Next line also be uncommenting.) - (if event (caml-read-event)) - ))) + (if event (caml-read-event))))) (defun caml-types-typed-make-overlay (target-buf pos) (interactive "p") @@ -776,20 +746,17 @@ The function uses two overlays. (if (and (equal target-buf (current-buffer)) (setq left (caml-types-get-pos target-buf (elt node 0)) right (caml-types-get-pos target-buf (elt node 1))) - (<= left pos) (> right pos) - ) + (<= left pos) (> right pos)) (setq start (min start left) - end (max end right)) - )) + end (max end right)))) (move-overlay caml-types-typed-ovl (max (point-min) (- start 1)) (min (point-max) (+ end 1)) target-buf) (cons start end))) (defun caml-types-version () - "internal version number of caml-types.el" + "Internal version number of caml-types.el." (interactive) - (message "4") -) + (message "4")) (provide 'caml-types) diff --git a/emacs/caml.el b/emacs/caml.el index 2bf4246d..e91417d2 100644 --- a/emacs/caml.el +++ b/emacs/caml.el @@ -803,12 +803,18 @@ variable caml-mode-indentation." ;; Newer emacs versions support line/char ranges ;; We will adapt OCaml to output error messages in a compatible format. -;; In the meantime we add the new format here in addition to the old one. +;; In the meantime we add new formats here in addition to the old one. (defconst caml-error-regexp-newstyle (concat "^[ A-\377]+ \"\\([^\"\n]+\\)\", line \\([0-9]+\\)," "char \\([0-9]+\\) to line \\([0-9]+\\), char \\([0-9]+\\):") "Regular expression matching the error messages produced by ocamlc/ocamlopt.") +(defconst caml-error-regexp-new-newstyle + (concat "^[ A-\377]+ \"\\([^\"\n]+\\)\", line \\([0-9]+\\), " + "characters \\([0-9]+\\)-\\([0-9]+\\):") + "Regular expression matching the error messages produced by ocamlc/ocamlopt.") + + (if (boundp 'compilation-error-regexp-alist) (progn (or (assoc caml-error-regexp @@ -820,6 +826,11 @@ variable caml-mode-indentation." compilation-error-regexp-alist) (setq compilation-error-regexp-alist (cons (list caml-error-regexp-newstyle 1 '(2 . 4) '(3 . 5)) + compilation-error-regexp-alist))) + (or (assoc caml-error-regexp-new-newstyle + compilation-error-regexp-alist) + (setq compilation-error-regexp-alist + (cons (list caml-error-regexp-new-newstyle 1 2 '(3 . 4)) compilation-error-regexp-alist))))) ;; A regexp to extract the range info diff --git a/lex/.depend b/lex/.depend index 455421e7..4c22eeb9 100644 --- a/lex/.depend +++ b/lex/.depend @@ -1,34 +1,34 @@ -common.cmi : syntax.cmi lexgen.cmi -compact.cmi : lexgen.cmi -cset.cmi : -lexer.cmi : parser.cmi -lexgen.cmi : syntax.cmi -output.cmi : syntax.cmi lexgen.cmi compact.cmi common.cmi -outputbis.cmi : syntax.cmi lexgen.cmi common.cmi -parser.cmi : syntax.cmi -syntax.cmi : cset.cmi -table.cmi : common.cmo : syntax.cmi lexgen.cmi common.cmi common.cmx : syntax.cmx lexgen.cmx common.cmi +common.cmi : syntax.cmi lexgen.cmi compact.cmo : table.cmi lexgen.cmi compact.cmi compact.cmx : table.cmx lexgen.cmx compact.cmi +compact.cmi : lexgen.cmi cset.cmo : cset.cmi cset.cmx : cset.cmi +cset.cmi : lexer.cmo : syntax.cmi parser.cmi lexer.cmi lexer.cmx : syntax.cmx parser.cmx lexer.cmi +lexer.cmi : parser.cmi lexgen.cmo : table.cmi syntax.cmi cset.cmi lexgen.cmi lexgen.cmx : table.cmx syntax.cmx cset.cmx lexgen.cmi +lexgen.cmi : syntax.cmi main.cmo : syntax.cmi parser.cmi outputbis.cmi output.cmi lexgen.cmi \ lexer.cmi cset.cmi compact.cmi common.cmi main.cmx : syntax.cmx parser.cmx outputbis.cmx output.cmx lexgen.cmx \ lexer.cmx cset.cmx compact.cmx common.cmx output.cmo : lexgen.cmi compact.cmi common.cmi output.cmi output.cmx : lexgen.cmx compact.cmx common.cmx output.cmi +output.cmi : syntax.cmi lexgen.cmi compact.cmi common.cmi outputbis.cmo : lexgen.cmi common.cmi outputbis.cmi outputbis.cmx : lexgen.cmx common.cmx outputbis.cmi +outputbis.cmi : syntax.cmi lexgen.cmi common.cmi parser.cmo : syntax.cmi cset.cmi parser.cmi parser.cmx : syntax.cmx cset.cmx parser.cmi +parser.cmi : syntax.cmi syntax.cmo : cset.cmi syntax.cmi syntax.cmx : cset.cmx syntax.cmi +syntax.cmi : cset.cmi table.cmo : table.cmi table.cmx : table.cmi +table.cmi : diff --git a/lex/Makefile b/lex/Makefile index fefaaa2c..5e3848fb 100644 --- a/lex/Makefile +++ b/lex/Makefile @@ -18,9 +18,19 @@ include ../config/Makefile CAMLRUN ?= ../boot/ocamlrun CAMLYACC ?= ../boot/ocamlyacc -CAMLC=$(CAMLRUN) ../boot/ocamlc -strict-sequence -nostdlib -I ../boot +ROOTDIR=.. + +ifeq "$(wildcard $(ROOTDIR)/flexdll/Makefile)" "" +export OCAML_FLEXLINK:= +else +export OCAML_FLEXLINK:=$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/flexdll/flexlink.exe +endif + +CAMLC=$(CAMLRUN) ../boot/ocamlc -strict-sequence -nostdlib -I ../boot \ + -use-prims ../byterun/primitives CAMLOPT=$(CAMLRUN) ../ocamlopt -nostdlib -I ../stdlib -COMPFLAGS=-w +33..39 -warn-error A -bin-annot -safe-string +COMPFLAGS=$(INCLUDES) -absname -w +a-4-9-41-42-44-45-48 -warn-error A \ + -safe-string -strict-sequence -strict-formats -bin-annot LINKFLAGS= YACCFLAGS=-v CAMLLEX=$(CAMLRUN) ../boot/ocamllex @@ -41,7 +51,7 @@ ocamllex.opt: $(OBJS:.cmo=.cmx) clean:: rm -f ocamllex ocamllex.opt - rm -f *.cmo *.cmi *.cmx *.cmt *.cmti *.o *~ + rm -f *.cmo *.cmi *.cmx *.cmt *.cmti *.$(O) *~ parser.ml parser.mli: parser.mly $(CAMLYACC) $(YACCFLAGS) parser.mly @@ -72,6 +82,6 @@ beforedepend:: lexer.ml $(CAMLOPT) -c $(COMPFLAGS) $< depend: beforedepend - $(CAMLDEP) *.mli *.ml > .depend + $(CAMLDEP) -slash *.mli *.ml > .depend include .depend diff --git a/lex/Makefile.nt b/lex/Makefile.nt index 44384c77..ed9900bb 100644 --- a/lex/Makefile.nt +++ b/lex/Makefile.nt @@ -13,71 +13,4 @@ #* * #************************************************************************** -# The lexer generator - -include ../config/Makefile -CAMLRUN ?= ../boot/ocamlrun -CAMLYACC ?= ../boot/ocamlyacc - -CAMLC=$(CAMLRUN) ../boot/ocamlc -I ../boot -ifeq "$(wildcard ../flexdll/Makefile)" "" - FLEXLINK_ENV= -else - FLEXLINK_ENV=OCAML_FLEXLINK="../boot/ocamlrun ../flexdll/flexlink.exe" -endif -CAMLOPT=$(FLEXLINK_ENV) $(CAMLRUN) ../ocamlopt -I ../stdlib -COMPFLAGS=-warn-error A -LINKFLAGS= -YACCFLAGS=-v -CAMLLEX=$(CAMLRUN) ../boot/ocamllex -CAMLDEP=$(CAMLRUN) ../tools/ocamldep -DEPFLAGS= - -OBJS=cset.cmo syntax.cmo parser.cmo lexer.cmo table.cmo lexgen.cmo \ - compact.cmo common.cmo output.cmo outputbis.cmo main.cmo - -all: ocamllex syntax.cmo -allopt: ocamllex.opt - -ocamllex: $(OBJS) - $(CAMLC) $(LINKFLAGS) -compat-32 -o ocamllex $(OBJS) - -ocamllex.opt: $(OBJS:.cmo=.cmx) - $(CAMLOPT) -o ocamllex.opt $(OBJS:.cmo=.cmx) - -clean:: - rm -f ocamllex ocamllex.opt - rm -f *.cmo *.cmi *.cmx *.$(O) - -parser.ml parser.mli: parser.mly - $(CAMLYACC) $(YACCFLAGS) parser.mly - -clean:: - rm -f parser.ml parser.mli parser.output - -beforedepend:: parser.ml parser.mli - -lexer.ml: lexer.mll - $(CAMLLEX) lexer.mll - -clean:: - rm -f lexer.ml - -beforedepend:: lexer.ml - -.SUFFIXES: -.SUFFIXES: .ml .cmo .mli .cmi .cmx - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -depend: beforedepend - $(CAMLDEP) *.mli *.ml > .depend - -include .depend +include Makefile diff --git a/lex/common.ml b/lex/common.ml index 38f82915..5024c829 100644 --- a/lex/common.ml +++ b/lex/common.ml @@ -139,7 +139,7 @@ let output_env ic oc tr env = env in List.iter - (fun ((x,pos),v) -> + (fun ((_,pos),v) -> fprintf oc "%s\n" !pref ; copy_chunk ic oc tr pos false ; begin match v with diff --git a/lex/compact.ml b/lex/compact.ml index 5bf7e68d..14eda9f5 100644 --- a/lex/compact.ml +++ b/lex/compact.ml @@ -129,7 +129,7 @@ let do_pack state_num orig compact = done; let rec try_pack = function [] -> b - | (pos, v) :: rem -> + | (pos, _v) :: rem -> if compact.c_check.(b + pos) = -1 then try_pack rem else pack_from (b+1) in diff --git a/lex/lexer.mll b/lex/lexer.mll index 99dd66f5..748f5e16 100644 --- a/lex/lexer.mll +++ b/lex/lexer.mll @@ -63,8 +63,6 @@ let handle_lexical_error fn lexbuf = with Lexical_error (msg, "", 0, 0) -> raise(Lexical_error(msg, file, line, column)) -let get_input_name () = Sys.argv.(Array.length Sys.argv - 1) - let warning lexbuf msg = let p = Lexing.lexeme_start_p lexbuf in Printf.eprintf "ocamllex warning:\nFile \"%s\", line %d, character %d: %s.\n" @@ -190,7 +188,7 @@ rule main = parse | ')' { Trparen } | '^' { Tcaret } | '-' { Tdash } - | '#' { Tsharp } + | '#' { Thash } | eof { Tend } | _ { raise_lexical_error lexbuf diff --git a/lex/lexgen.ml b/lex/lexgen.ml index 74d99c74..4054f27c 100644 --- a/lex/lexgen.ml +++ b/lex/lexgen.ml @@ -17,7 +17,7 @@ (* Compiling a lexer definition *) open Syntax -open Printf +(*open Printf*) exception Memory_overflow @@ -95,9 +95,6 @@ module TagMap = module IdSet = Set.Make (struct type t = ident let compare = id_compare end) -module IdMap = - Map.Make (struct type t = ident let compare = id_compare end) - (*********************) (* Variable cleaning *) (*********************) @@ -305,15 +302,6 @@ let rec encode_regexp char_vars act = function a previous similar tag. *) -let incr_pos = function - | None -> None - | Some i -> Some (i+1) - -let decr_pos = function - | None -> None - | Some i -> Some (i-1) - - let opt = true let mk_seq r1 r2 = match r1,r2 with @@ -553,7 +541,7 @@ let rec nullable = function | Chars (_,_)|Action _ -> false | Seq(r1,r2) -> nullable r1 && nullable r2 | Alt(r1,r2) -> nullable r1 || nullable r2 - | Star r -> true + | Star _ -> true let rec emptymatch = function | Empty | Chars (_,_) | Action _ -> Tags.empty @@ -630,6 +618,7 @@ type 'a dfa_state = others : ('a * int TagMap.t) MemMap.t} +(* let dtag oc t = fprintf oc "%s<%s>" t.id (if t.start then "s" else "e") @@ -656,6 +645,7 @@ let dstate {final=(act,(_,m)) ; others=o} = dtag_map (fun x -> eprintf "%d" x) (fun () -> prerr_string " ,") m) (fun () -> prerr_endline "") o +*) let dfa_state_empty = @@ -858,7 +848,7 @@ let create_init_state pos = (fun (t,tags) st -> match t with | ToAction n -> - let on,otags = st.final in + let on,_otags = st.final in if n < on then {st with final = (n, (0,create_mem_map tags gen))} else @@ -883,10 +873,12 @@ let get_map t st = match t with let dest = function | Copy (d,_) | Set d -> d and orig = function | Copy (_,o) -> o | Set _ -> -1 +(* let pmv oc mv = fprintf oc "%d <- %d" (dest mv) (orig mv) let pmvs oc mvs = List.iter (fun mv -> fprintf oc "%a " pmv mv) mvs ; output_char oc '\n' ; flush oc +*) (* Topological sort << a la louche >> *) @@ -1105,6 +1097,7 @@ let translate_state shortest_match tags chars follow st = reachs chars follow st.others) end +(* let dtags chan tags = Tags.iter (fun t -> fprintf chan " %a" dtag t) @@ -1126,6 +1119,7 @@ let dfollow t = dtransset t.(i) done ; prerr_endline "]" +*) let make_tag_entry id start act a r = match a with diff --git a/lex/main.ml b/lex/main.ml index d49d832e..fd01325d 100644 --- a/lex/main.ml +++ b/lex/main.ml @@ -77,11 +77,11 @@ let main () = let (entries, transitions) = Lexgen.make_dfa def.entrypoints in if !ml_automata then begin Outputbis.output_lexdef - source_name ic oc tr + ic oc tr def.header def.refill_handler entries transitions def.trailer end else begin let tables = Compact.compact_tables transitions in - Output.output_lexdef source_name ic oc tr + Output.output_lexdef ic oc tr def.header def.refill_handler tables entries def.trailer end; close_in ic; diff --git a/lex/output.ml b/lex/output.ml index 28832039..17df3b3e 100644 --- a/lex/output.ml +++ b/lex/output.ml @@ -72,7 +72,7 @@ let output_tables oc tbl = (* Output the entries *) -let output_entry sourcefile ic oc has_refill oci e = +let output_entry ic oc has_refill oci e = let init_num, init_moves = e.auto_initial_state in fprintf oc "%s %alexbuf =\ \n %a%a __ocaml_lex_%s_rec %alexbuf %d\n" @@ -115,7 +115,7 @@ let output_entry sourcefile ic oc has_refill oci e = exception Table_overflow -let output_lexdef sourcefile ic oc oci header rh tables entry_points trailer = +let output_lexdef ic oc oci header rh tables entry_points trailer = if not !Common.quiet_mode then Printf.printf "%d states, %d transitions, table size %d bytes\n" (Array.length tables.tbl_base) @@ -141,11 +141,11 @@ let output_lexdef sourcefile ic oc oci header rh tables entry_points trailer = [] -> () | entry1 :: entries -> output_string oc "let rec "; - output_entry sourcefile ic oc has_refill oci entry1; + output_entry ic oc has_refill oci entry1; List.iter (fun e -> output_string oc "and "; - output_entry sourcefile ic oc has_refill oci e) + output_entry ic oc has_refill oci e) entries; output_string oc ";;\n\n"; end; diff --git a/lex/output.mli b/lex/output.mli index c591824b..13956aa9 100644 --- a/lex/output.mli +++ b/lex/output.mli @@ -16,7 +16,7 @@ (* Output the DFA tables and its entry points *) val output_lexdef: - string -> in_channel -> out_channel -> Common.line_tracker -> + in_channel -> out_channel -> Common.line_tracker -> Syntax.location -> Syntax.location option -> Compact.lex_tables -> diff --git a/lex/outputbis.ml b/lex/outputbis.ml index 05b83118..fc8dfac8 100644 --- a/lex/outputbis.ml +++ b/lex/outputbis.ml @@ -37,14 +37,14 @@ let output_auto_defs oc has_refill = \n if lexbuf.Lexing.lex_eof_reached then\ \n state lexbuf k 256\ \n else begin\ -\n __ocaml_lex_refill (fun lexbuf -> +\n __ocaml_lex_refill (fun lexbuf ->\ \n lexbuf.Lexing.refill_buff lexbuf ;\ \n __ocaml_lex_next_char lexbuf state k)\ \n lexbuf\ \n end\ \n end else begin\ \n let i = lexbuf.Lexing.lex_curr_pos in\ -\n let c = lexbuf.Lexing.lex_buffer.[i] in\ +\n let c = Bytes.get lexbuf.Lexing.lex_buffer i in\ \n lexbuf.Lexing.lex_curr_pos <- i+1 ;\ \n state lexbuf k (Char.code c)\ \n end\ @@ -61,7 +61,7 @@ let output_auto_defs oc has_refill = \n end\ \n end else begin\ \n let i = lexbuf.Lexing.lex_curr_pos in\ -\n let c = lexbuf.Lexing.lex_buffer.[i] in\ +\n let c = Bytes.get lexbuf.Lexing.lex_buffer i in\ \n lexbuf.Lexing.lex_curr_pos <- i+1 ;\ \n Char.code c\ \n end\ @@ -188,7 +188,7 @@ let output_automata oc has_refill auto = (* Output the entries *) -let output_entry sourcefile ic oc has_refill tr e = +let output_entry ic oc has_refill tr e = let init_num, init_moves = e.auto_initial_state in fprintf oc "%s %alexbuf =\n __ocaml_lex_init_lexbuf lexbuf %d; %a" e.auto_name output_args e.auto_args @@ -221,7 +221,7 @@ let output_entry sourcefile ic oc has_refill tr e = (* Main output function *) -let output_lexdef sourcefile ic oc tr header rh +let output_lexdef ic oc tr header rh entry_points transitions trailer = copy_chunk ic oc tr header false; @@ -231,10 +231,10 @@ let output_lexdef sourcefile ic oc tr header rh [] -> () | entry1 :: entries -> output_string oc "let rec "; - output_entry sourcefile ic oc has_refill tr entry1; + output_entry ic oc has_refill tr entry1; List.iter (fun e -> output_string oc "and "; - output_entry sourcefile ic oc has_refill tr e) + output_entry ic oc has_refill tr e) entries; output_string oc ";;\n\n"; end; diff --git a/lex/outputbis.mli b/lex/outputbis.mli index 93a84b0d..44eb0e47 100644 --- a/lex/outputbis.mli +++ b/lex/outputbis.mli @@ -14,7 +14,6 @@ (**************************************************************************) val output_lexdef : - string -> in_channel -> out_channel -> Common.line_tracker -> diff --git a/lex/parser.mly b/lex/parser.mly index 99586528..0a1bb5d9 100644 --- a/lex/parser.mly +++ b/lex/parser.mly @@ -53,13 +53,13 @@ let as_cset = function %token Taction %token Trule Tparse Tparse_shortest Tand Tequal Tend Tor Tunderscore Teof Tlbracket Trbracket Trefill -%token Tstar Tmaybe Tplus Tlparen Trparen Tcaret Tdash Tlet Tas Tsharp +%token Tstar Tmaybe Tplus Tlparen Trparen Tcaret Tdash Tlet Tas Thash %right Tas %left Tor %nonassoc CONCAT %nonassoc Tmaybe Tstar Tplus -%left Tsharp +%left Thash %nonassoc Tident Tchar Tstring Tunderscore Teof Tlbracket Tlparen %start lexer_definition @@ -145,7 +145,7 @@ regexp: { Alternative(Epsilon, $1) } | regexp Tplus { Sequence(Repetition (remove_as $1), $1) } - | regexp Tsharp regexp + | regexp Thash regexp { let s1 = as_cset $1 and s2 = as_cset $3 in diff --git a/man/ocaml.m b/man/ocaml.m index 54d20a99..1d320022 100644 --- a/man/ocaml.m +++ b/man/ocaml.m @@ -38,7 +38,7 @@ that permits interactive use of the OCaml system through a read-eval-print loop. In this mode, the system repeatedly reads OCaml phrases from the input, then typechecks, compiles and evaluates them, then prints the inferred type and result value, if any. The -system prints a # (sharp) prompt before reading each phrase. +system prints a # (hash) prompt before reading each phrase. A toplevel phrase can span several lines. It is terminated by ;; (a double-semicolon). The syntax of toplevel phrases is as follows. @@ -142,6 +142,11 @@ Opens the given module before starting the toplevel. If several options are given, they are processed in order, just as if the statements open! module1;; ... open! moduleN;; were input. .TP +.BI \-plugin \ plugin +Dynamically load the code of the given +.I plugin +(a .cmo or .cma file) in the toplevel. +.TP .BI \-ppx \ command After parsing, pipe the abstract syntax tree through the preprocessor .IR command . @@ -185,6 +190,17 @@ interactive session. .B \-strict\-sequence Force the left-hand part of each sequence to have type unit. .TP +.B \-unboxed\-types +When a type is unboxable (i.e. a record with a single argument or a +concrete datatype with a single constructor of one argument) it will +be unboxed unless annotated with +.BR [@@ocaml.boxed] . +.TP +.B \-no-unboxed\-types +When a type is unboxable it will be boxed unless annotated with +.BR [@@ocaml.unboxed] . +This is the default. +.TP .B \-unsafe Turn bound checking off on array and string accesses (the .BR v.(i) and s.[i] @@ -206,6 +222,9 @@ Print version string and exit. .B \-vnum Print short version number and exit. .TP +.B \-no\-version +Do not print the version banner at startup. +.TP .BI \-w \ warning\-list Enable or disable warnings according to the argument .IR warning-list . diff --git a/man/ocamlc.m b/man/ocamlc.m index b5360dcf..23c98170 100644 --- a/man/ocamlc.m +++ b/man/ocamlc.m @@ -44,7 +44,7 @@ The .BR ocamlc (1) command has a command-line interface similar to the one of most C compilers. It accepts several types of arguments and processes them -sequentially: +sequentially, after all options have been processed: Arguments ending in .mli are taken to be source files for compilation unit interfaces. Interfaces specify the names exported by @@ -526,6 +526,15 @@ contents of the object files a.cmo, b.cmo and c.cmo. These contents can be referenced as P.A, P.B and P.C in the remainder of the program. .TP +.BI \-plugin \ plugin +Dynamically load the code of the given +.I plugin +(a .cmo, .cma or .cmxs file) in the compiler. The plugin must exist in +the same kind of code as the compiler (ocamlc.byte must load bytecode +plugins, while ocamlc.opt must load native code plugins), and +extension adaptation is done automatically for .cma files (to .cmxs files +if the compiler is compiled in native code). +.TP .BI \-pp \ command Cause the compiler to call the given .I command @@ -593,6 +602,17 @@ Compile or link multithreaded programs, in combination with the system "threads" library described in .IR The\ OCaml\ user's\ manual . .TP +.B \-unboxed\-types +When a type is unboxable (i.e. a record with a single argument or a +concrete datatype with a single constructor of one argument) it will +be unboxed unless annotated with +.BR [@@ocaml.boxed] . +.TP +.B \-no-unboxed\-types +When a type is unboxable it will be boxed unless annotated with +.BR [@@ocaml.unboxed] . +This is the default. +.TP .B \-unsafe Turn bound checking off for array and string accesses (the .BR v.(i) and s.[i] @@ -882,6 +902,12 @@ mutually recursive types. 59 \ \ Assignment on non-mutable value. +60 +\ \ Unused module declaration. + +61 +\ \ Unannotated unboxable type in primitive declaration. + The letters stand for the following sets of warnings. Any letter not mentioned here corresponds to the empty set. @@ -935,7 +961,7 @@ mentioned here corresponds to the empty set. .IP The default setting is -.BR \-w\ +a\-4\-6\-7\-9\-27\-29\-32..39\-41\-42\-44\-45\-48\-50 . +.BR \-w\ +a\-4\-6\-7\-9\-27\-29\-32..39\-41\-42\-44\-45\-48\-50\-60 . Note that warnings .BR 5 \ and \ 10 are not always triggered, depending on the internals of the type checker. @@ -965,7 +991,7 @@ warnings or modify existing warnings. The default setting is .B \-warn\-error \-a+31 -(all warnings are non-fatal except 31). +(only warning 31 is fatal). .TP .B \-warn\-help Show the description of all available warning numbers. diff --git a/man/ocamlopt.m b/man/ocamlopt.m index 1d50c143..f3fb3470 100644 --- a/man/ocamlopt.m +++ b/man/ocamlopt.m @@ -44,7 +44,7 @@ command has a command-line interface very close to that of .BR ocamlc (1). It accepts the same types of arguments and processes them -sequentially: +sequentially, after all options have been processed: Arguments ending in .mli are taken to be source files for compilation unit interfaces. Interfaces specify the names exported by @@ -456,6 +456,15 @@ See .IR "The OCaml user's manual" , chapter "Native-code compilation" for more details. .TP +.BI \-plugin \ plugin +Dynamically load the code of the given +.I plugin +(a .cmo, .cma or .cmxs file) in the compiler. The plugin must exist in +the same kind of code as the compiler (ocamlopt.byte must load bytecode +plugins, while ocamlopt.opt must load native code plugins), and +extension adaptation is done automatically for .cma files (to .cmxs files +if the compiler is compiled in native code). +.TP .BI \-pp \ command Cause the compiler to call the given .I command @@ -539,6 +548,17 @@ Compile or link multithreaded programs, in combination with the system threads library described in .IR "The OCaml user's manual" . .TP +.B \-unboxed\-types +When a type is unboxable (i.e. a record with a single argument or a +concrete datatype with a single constructor of one argument) it will +be unboxed unless annotated with +.BR [@@ocaml.boxed] . +.TP +.B \-no-unboxed\-types +When a type is unboxable it will be boxed unless annotated with +.BR [@@ocaml.unboxed] . +This is the default. +.TP .B \-unsafe Turn bound checking off for array and string accesses (the .BR v.(i) and s.[i] @@ -606,8 +626,8 @@ compiling your program with later versions of OCaml when they add new warnings or modify existing warnings. The default setting is -.B \-warn\-error \-a -(all warnings are non-fatal). +.B \-warn\-error \-a+31 +(only warning 31 is fatal). .TP .B \-warn\-help Show the description of all available warning numbers. diff --git a/man/ocamlyacc.m b/man/ocamlyacc.m index 57df9e74..f522d5cc 100644 --- a/man/ocamlyacc.m +++ b/man/ocamlyacc.m @@ -79,6 +79,9 @@ instead of the default naming convention. .B \-q This option has no effect. .TP +.B \--strict +Reject grammars with conflicts. +.TP .B \-v Generate a description of the parsing tables and a report on conflicts resulting from ambiguities in the grammar. The description is put in diff --git a/middle_end/alias_analysis.ml b/middle_end/alias_analysis.ml old mode 100644 new mode 100755 index 2486312f..0ed9ae29 --- a/middle_end/alias_analysis.ml +++ b/middle_end/alias_analysis.ml @@ -144,7 +144,7 @@ and fetch_symbol_field | fields -> begin match List.nth fields field with | None -> - Misc.fatal_errorf "constant field access to an inconstant %a" + Misc.fatal_errorf "Constant field access to an inconstant %a" Symbol.print sym | Some v -> fetch_variable definitions v ~the_dead_constant diff --git a/middle_end/augment_specialised_args.ml b/middle_end/augment_specialised_args.ml old mode 100644 new mode 100755 index 50f6420f..037918c9 --- a/middle_end/augment_specialised_args.ml +++ b/middle_end/augment_specialised_args.ml @@ -16,7 +16,6 @@ [@@@ocaml.warning "+a-4-9-30-40-41-42"] -module A = Simple_value_approx module E = Inline_and_simplify_aux.Env module B = Inlining_cost.Benefit @@ -159,7 +158,7 @@ module Processed_what_to_specialise = struct of closures (corresponding to another new specialised argument), we should re-use its "new outer var" to avoid duplication of projection definitions. Likewise if the definition is just - [Existing_inner_free_var], in in which case we can use the + [Existing_inner_free_var], in which case we can use the corresponding existing outer free variable. *) let new_outer_var, t = let existing_outer_var = diff --git a/middle_end/backend_intf.mli b/middle_end/backend_intf.mli old mode 100644 new mode 100755 index efdbbc3c..c9e00928 --- a/middle_end/backend_intf.mli +++ b/middle_end/backend_intf.mli @@ -39,7 +39,7 @@ module type S = sig (** [true] iff the target architecture is big endian. *) val big_endian : bool - (** The maximum number of arguments that is is reasonable for a function + (** The maximum number of arguments that is reasonable for a function to have. This should be fewer than the threshold that causes non-self tail call optimization to be inhibited (in particular, if it would entail passing arguments on the stack; see [Selectgen]). *) diff --git a/middle_end/base_types/set_of_closures_id.mli b/middle_end/base_types/set_of_closures_id.mli old mode 100644 new mode 100755 index 1bcfc694..724c6416 --- a/middle_end/base_types/set_of_closures_id.mli +++ b/middle_end/base_types/set_of_closures_id.mli @@ -17,7 +17,7 @@ [@@@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]). *) + of closures (viz. [Set_of_closures]). *) include Identifiable.S diff --git a/middle_end/closure_conversion.ml b/middle_end/closure_conversion.ml old mode 100644 new mode 100755 index 7f01971b..93f907f5 --- a/middle_end/closure_conversion.ml +++ b/middle_end/closure_conversion.ml @@ -28,6 +28,7 @@ type t = { symbol_for_global' : (Ident.t -> Symbol.t); filename : string; mutable imported_symbols : Symbol.Set.t; + mutable declared_symbols : (Symbol.t * Flambda.constant_defining_value) list; } let add_default_argument_wrappers lam = @@ -40,22 +41,24 @@ let add_default_argument_wrappers lam = Primitive.simple ~name:Closure_conversion_aux.stub_hack_prim_name ~arity:1 ~alloc:false in - Lprim (Pccall stub_prim, [body]) + Lprim (Pccall stub_prim, [body], Location.none) in let defs_are_all_functions (defs : (_ * Lambda.lambda) list) = List.for_all (function (_, Lambda.Lfunction _) -> true | _ -> false) defs in let f (lam : Lambda.lambda) : Lambda.lambda = match lam with - | Llet (( Strict | Alias | StrictOpt), id, - Lfunction {kind; params; body = fbody; attr}, body) -> + | Llet (( Strict | Alias | StrictOpt), _k, id, + Lfunction {kind; params; body = fbody; attr; loc}, body) -> begin match - Simplif.split_default_wrapper id kind params fbody attr - ~create_wrapper_body:stubify + Simplif.split_default_wrapper ~id ~kind ~params ~body:fbody + ~attr ~wrapper_attr:Lambda.default_function_attribute + ~loc ~create_wrapper_body:stubify () with - | [fun_id, def] -> Llet (Alias, fun_id, def, body) + | [fun_id, def] -> Llet (Alias, Pgenval, fun_id, def, body) | [fun_id, def; inner_fun_id, def_inner] -> - Llet (Alias, inner_fun_id, def_inner, Llet (Alias, fun_id, def, body)) + Llet (Alias, Pgenval, inner_fun_id, def_inner, + Llet (Alias, Pgenval, fun_id, def, body)) | _ -> assert false end | Lletrec (defs, body) as lam -> @@ -64,9 +67,10 @@ let add_default_argument_wrappers lam = List.flatten (List.map (function - | (id, Lambda.Lfunction {kind; params; body; attr}) -> - Simplif.split_default_wrapper id kind params body attr - ~create_wrapper_body:stubify + | (id, Lambda.Lfunction {kind; params; body; attr; loc}) -> + Simplif.split_default_wrapper ~id ~kind ~params ~body + ~attr ~wrapper_attr:Lambda.default_function_attribute + ~loc ~create_wrapper_body:stubify () | _ -> assert false) defs) in @@ -109,43 +113,63 @@ let tupled_function_call_stub original_params unboxed_version ~body ~stub:true ~dbg:Debuginfo.none ~inline:Default_inline ~specialise:Default_specialise ~is_a_functor:false -let rec eliminate_const_block (const : Lambda.structured_constant) - : Lambda.lambda = - match const with - | Const_block (tag, consts) -> - Lprim (Pmakeblock (tag, Asttypes.Immutable), - List.map eliminate_const_block consts) - | Const_base _ - | Const_pointer _ - | Const_immstring _ - | Const_float_array _ -> Lconst const - -let default_debuginfo ?(inner_debuginfo = Debuginfo.none) env_debuginfo = - match env_debuginfo with - | None -> inner_debuginfo - | Some debuginfo -> debuginfo +let register_const t (constant:Flambda.constant_defining_value) name + : Flambda.constant_defining_value_block_field * string = + let current_compilation_unit = Compilation_unit.get_current_exn () in + (* Create a variable to ensure uniqueness of the symbol *) + let var = Variable.create ~current_compilation_unit name in + let symbol = + Symbol.create current_compilation_unit + (Linkage_name.create (Variable.unique_name var)) + in + t.declared_symbols <- (symbol, constant) :: t.declared_symbols; + Symbol symbol, name -let rec close_const t env (const : Lambda.structured_constant) - : Flambda.named * string = +let rec declare_const t (const : Lambda.structured_constant) + : Flambda.constant_defining_value_block_field * string = match const with | Const_base (Const_int c) -> Const (Int c), "int" | Const_base (Const_char c) -> Const (Char c), "char" - | Const_base (Const_string (s, _)) -> Allocated_const (String s), "string" + | Const_base (Const_string (s, _)) -> + let const, name = + if Config.safe_string then + Flambda.Allocated_const (Immutable_string s), "immstring" + else Flambda.Allocated_const (String s), "string" + in + register_const t const name | Const_base (Const_float c) -> - Allocated_const (Float (float_of_string c)), "float" - | Const_base (Const_int32 c) -> Allocated_const (Int32 c), "int32" - | Const_base (Const_int64 c) -> Allocated_const (Int64 c), "int64" + register_const t + (Allocated_const (Float (float_of_string c))) + "float" + | Const_base (Const_int32 c) -> + register_const t (Allocated_const (Int32 c)) "int32" + | Const_base (Const_int64 c) -> + register_const t (Allocated_const (Int64 c)) "int64" | Const_base (Const_nativeint c) -> - Allocated_const (Nativeint c), "nativeint" + register_const t (Allocated_const (Nativeint c)) "nativeint" | Const_pointer c -> Const (Const_pointer c), "pointer" - | Const_immstring c -> Allocated_const (Immutable_string c), "immstring" + | Const_immstring c -> + register_const t (Allocated_const (Immutable_string c)) "immstring" | Const_float_array c -> - Allocated_const (Immutable_float_array (List.map float_of_string c)), + register_const t + (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" + | Const_block (tag, consts) -> + let const : Flambda.constant_defining_value = + Block (Tag.create_exn tag, + List.map (fun c -> fst (declare_const t c)) consts) + in + register_const t const "const_block" + +let close_const t (const : Lambda.structured_constant) + : Flambda.named * string = + match declare_const t const with + | Const c, name -> + Const c, name + | Symbol s, name -> + Symbol s, name -and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t = +let rec close t env (lam : Lambda.lambda) : Flambda.t = match lam with | Lvar id -> begin match Env.find_var_exn env id with @@ -158,30 +182,34 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t = Ident.print id end | Lconst cst -> - let cst, name = close_const t env cst in + let cst, name = close_const t cst in name_expr cst ~name:("const_" ^ name) - | Llet ((Strict | Alias | StrictOpt), id, defining_expr, body) -> + | Llet ((Strict | Alias | StrictOpt), _value_kind, id, defining_expr, body) -> + (* TODO: keep value_kind in flambda *) let var = Variable.create_with_same_name_as_ident id in let defining_expr = close_let_bound_expression t var env defining_expr in let body = close t (Env.add_var env id var) body in Flambda.create_let var defining_expr body - | Llet (Variable, id, defining_expr, body) -> + | Llet (Variable, block_kind, id, defining_expr, body) -> let mut_var = Mutable_variable.of_ident id in let var = Variable.create_with_same_name_as_ident id in let defining_expr = close_let_bound_expression t var env defining_expr in let body = close t (Env.add_mutable_var env id mut_var) body in - Flambda.create_let var defining_expr (Let_mutable (mut_var, var, body)) - | Lfunction { kind; params; body; attr; } -> + Flambda.create_let var defining_expr + (Let_mutable + { var = mut_var; + initial_value = var; + body; + contents_kind = block_kind }) + | Lfunction { kind; params; body; attr; loc; } -> let name = (* Name anonymous functions by their source location, if known. *) - match body with - | Levent (_, { lev_loc }) -> - Format.asprintf "anon-fn[%a]" Location.print_compact lev_loc - | _ -> "anon-fn" + if loc = Location.none then "anon-fn" + else Format.asprintf "anon-fn[%a]" Location.print_compact loc in let closure_bound_var = Variable.create name in (* CR-soon mshinwell: some of this is now very similar to the let rec case @@ -191,7 +219,7 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t = let decl = Function_decl.create ~let_rec_ident:None ~closure_bound_var ~kind ~params ~body ~inline:attr.inline ~specialise:attr.specialise - ~is_a_functor:attr.is_a_functor + ~is_a_functor:attr.is_a_functor ~loc in close_functions t env (Function_decls.create [decl]) in @@ -216,10 +244,7 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t = func = func_var; args; kind = Indirect; - dbg = - default_debuginfo - ~inner_debuginfo:(Debuginfo.from_location Dinfo_call ap_loc) - debuginfo; + dbg = Debuginfo.from_location ap_loc; inline = ap_inlined; specialise = ap_specialised; }))) @@ -233,7 +258,8 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t = (* Identify any bindings in the [let rec] that are functions. These will be named after the corresponding identifier in the [let rec]. *) List.map (function - | (let_rec_ident, Lambda.Lfunction { kind; params; body; attr; }) -> + | (let_rec_ident, + Lambda.Lfunction { kind; params; body; attr; loc }) -> let closure_bound_var = Variable.create_with_same_name_as_ident let_rec_ident in @@ -241,7 +267,7 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t = Function_decl.create ~let_rec_ident:(Some let_rec_ident) ~closure_bound_var ~kind ~params ~body ~inline:attr.inline ~specialise:attr.specialise - ~is_a_functor:attr.is_a_functor + ~is_a_functor:attr.is_a_functor ~loc in Some function_declaration | _ -> None) @@ -306,7 +332,7 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t = | Lsend (kind, meth, obj, args, loc) -> let meth_var = Variable.create "meth" in let obj_var = Variable.create "obj" in - let dbg = Debuginfo.from_location Dinfo_call loc in + let dbg = Debuginfo.from_location loc in Flambda.create_let meth_var (Expr (close t env meth)) (Flambda.create_let obj_var (Expr (close t env obj)) (Lift_code.lifting_helper (close_list t env args) @@ -314,7 +340,9 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t = ~name:"send_arg" ~create_body:(fun args -> Send { kind; meth = meth_var; obj = obj_var; args; dbg; }))) - | Lprim ((Pdivint | Pmodint) as prim, [arg1; arg2]) + | Lprim ((Pdivint Safe | Pmodint Safe + | Pdivbint { is_safe = Safe } | Pmodbint { is_safe = Safe }) as prim, + [arg1; arg2], loc) when not !Clflags.fast -> (* not -unsafe *) let arg2 = close t env arg2 in let arg1 = close t env arg1 in @@ -326,16 +354,42 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t = let exn_symbol = t.symbol_for_global' Predef.ident_division_by_zero in + let dbg = Debuginfo.from_location loc in + let zero_const : Flambda.named = + match prim with + | Pdivint _ | Pmodint _ -> + Const (Int 0) + | Pdivbint { size = Pint32 } | Pmodbint { size = Pint32 } -> + Allocated_const (Int32 0l) + | Pdivbint { size = Pint64 } | Pmodbint { size = Pint64 } -> + Allocated_const (Int64 0L) + | Pdivbint { size = Pnativeint } | Pmodbint { size = Pnativeint } -> + Allocated_const (Nativeint 0n) + | _ -> assert false + in + let prim : Lambda.primitive = + match prim with + | Pdivint _ -> Pdivint Unsafe + | Pmodint _ -> Pmodint Unsafe + | Pdivbint { size } -> Pdivbint { size; is_safe = Unsafe } + | Pmodbint { size } -> Pmodbint { size; is_safe = Unsafe } + | _ -> assert false + in + let comparison : Lambda.primitive = + match prim with + | Pdivint _ | Pmodint _ -> Pintcomp Ceq + | Pdivbint { size } | Pmodbint { size } -> Pbintcomp (size,Ceq) + | _ -> assert false + in t.imported_symbols <- Symbol.Set.add exn_symbol t.imported_symbols; - Flambda.create_let zero (Const (Int 0)) + Flambda.create_let zero zero_const (Flambda.create_let exn (Symbol exn_symbol) (Flambda.create_let denominator (Expr arg2) (Flambda.create_let numerator (Expr arg1) (Flambda.create_let is_zero - (Prim (Pintcomp Ceq, [zero; denominator], Debuginfo.none)) + (Prim (comparison, [zero; denominator], dbg)) (If_then_else (is_zero, - name_expr (Prim (Praise Raise_regular, [exn], - default_debuginfo debuginfo)) + name_expr (Prim (Praise Raise_regular, [exn], dbg)) ~name:"dummy", (* CR-someday pchambart: find the right event. mshinwell: I briefly looked at this, and couldn't @@ -344,13 +398,13 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t = are suitable. I had to add a new one for a similar case in the array data types work. mshinwell: deferred CR *) - (* Debuginfo.from_raise event *) name_expr ~name:"result" - (Prim (prim, [numerator; denominator], - Debuginfo.none)))))))) - | Lprim ((Pdivint | Pmodint), _) when not !Clflags.fast -> + (Prim (prim, [numerator; denominator], dbg)))))))) + | Lprim ((Pdivint Safe | Pmodint Safe + | Pdivbint { is_safe = Safe } | Pmodbint { is_safe = Safe }), _, _) + when not !Clflags.fast -> Misc.fatal_error "Pdivint / Pmodint must have exactly two arguments" - | Lprim (Psequor, [arg1; arg2]) -> + | Lprim (Psequor, [arg1; arg2], _) -> let arg1 = close t env arg1 in let arg2 = close t env arg2 in let const_true = Variable.create "const_true" in @@ -358,7 +412,7 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t = Flambda.create_let const_true (Const (Int 1)) (Flambda.create_let cond (Expr arg1) (If_then_else (cond, Var const_true, arg2))) - | Lprim (Psequand, [arg1; arg2]) -> + | Lprim (Psequand, [arg1; arg2], _) -> let arg1 = close t env arg1 in let arg2 = close t env arg2 in let const_false = Variable.create "const_false" in @@ -366,11 +420,11 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t = Flambda.create_let const_false (Const (Int 0)) (Flambda.create_let cond (Expr arg1) (If_then_else (cond, arg2, Var const_false))) - | Lprim ((Psequand | Psequor), _) -> + | Lprim ((Psequand | Psequor), _, _) -> Misc.fatal_error "Psequand / Psequor must have exactly two arguments" - | Lprim (Pidentity, [arg]) -> close t env arg - | Lprim (Pdirapply loc, [funct; arg]) - | Lprim (Prevapply loc, [arg; funct]) -> + | Lprim (Pidentity, [arg], _) -> close t env arg + | Lprim (Pdirapply, [funct; arg], loc) + | Lprim (Prevapply, [arg; funct], loc) -> let apply : Lambda.lambda_apply = { ap_func = funct; ap_args = [arg]; @@ -383,47 +437,44 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t = ap_specialised = Default_specialise; } in - close t env ?debuginfo (Lambda.Lapply apply) - | Lprim (Praise kind, [Levent (arg, event)]) -> + close t env (Lambda.Lapply apply) + | Lprim (Praise kind, [arg], loc) -> let arg_var = Variable.create "raise_arg" in + let dbg = Debuginfo.from_location loc in Flambda.create_let arg_var (Expr (close t env arg)) (name_expr - (Prim (Praise kind, [arg_var], - default_debuginfo ~inner_debuginfo:(Debuginfo.from_raise event) - debuginfo)) + (Prim (Praise kind, [arg_var], dbg)) ~name:"raise") - | Lprim (Pfield _, [Lprim (Pgetglobal id, [])]) + | Lprim (Pfield _, [Lprim (Pgetglobal id, [],_)], _) when Ident.same id t.current_unit_id -> Misc.fatal_errorf "[Pfield (Pgetglobal ...)] for the current compilation \ unit is forbidden upon entry to the middle end" - | Lprim (Psetfield (_, _, _), [Lprim (Pgetglobal _, []); _]) -> + | Lprim (Psetfield (_, _, _), [Lprim (Pgetglobal _, [], _); _], _) -> Misc.fatal_errorf "[Psetfield (Pgetglobal ...)] is \ forbidden upon entry to the middle end" - | Lprim (Pgetglobal id, []) when Ident.is_predef_exn id -> + | Lprim (Pgetglobal id, [], _) when Ident.is_predef_exn id -> let symbol = t.symbol_for_global' id in t.imported_symbols <- Symbol.Set.add symbol t.imported_symbols; name_expr (Symbol symbol) ~name:"predef_exn" - | Lprim (Pgetglobal id, []) -> + | Lprim (Pgetglobal id, [], _) -> assert (not (Ident.same id t.current_unit_id)); let symbol = t.symbol_for_global' id in t.imported_symbols <- Symbol.Set.add symbol t.imported_symbols; name_expr (Symbol symbol) ~name:"Pgetglobal" - | Lprim (p, args) -> + | Lprim (p, args, loc) -> (* One of the important consequences of the ANF-like representation here is that we obtain names corresponding to the components of blocks being made (with [Pmakeblock]). This information can be used by the simplification pass to increase the likelihood of eliminating the allocation, since some field accesses can be tracked back to known - field values. ,*) + field values. *) let name = Printlambda.name_of_primitive p in + let dbg = Debuginfo.from_location loc in Lift_code.lifting_helper (close_list t env args) ~evaluation_order:`Right_to_left ~name:(name ^ "_arg") ~create_body:(fun args -> - let inner_debuginfo = - Debuginfo.from_filename Debuginfo.Dinfo_call t.filename - in - name_expr (Prim (p, args, default_debuginfo debuginfo ~inner_debuginfo)) + name_expr (Prim (p, args, dbg)) ~name) | Lswitch (arg, sw) -> let scrutinee = Variable.create "switch" in @@ -437,7 +488,7 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t = blocks = List.map aux sw.sw_blocks; failaction = Misc.may_map (close t env) sw.sw_failaction; })) - | Lstringswitch (arg, sw, def) -> + | Lstringswitch (arg, sw, def, _) -> let scrutinee = Variable.create "string_switch" in Flambda.create_let scrutinee (Expr (close t env arg)) (String_switch (scrutinee, @@ -490,13 +541,7 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t = let new_value_var = Variable.create "new_value" in Flambda.create_let new_value_var (Expr (close t env new_value)) (Assign { being_assigned; new_value = new_value_var; }) - | Levent (lam, ev) -> begin - match ev.lev_kind with - | Lev_after _ -> - close t env ~debuginfo:(Debuginfo.from_call ev) lam - | _ -> - close t env lam - end + | Levent (lam, _) -> close t env lam | Lifused _ -> (* [Lifused] is used to mark that this expression should be alive only if an identifier is. Every use should have been removed by @@ -516,14 +561,8 @@ and close_functions t external_env function_declarations : Flambda.named = let all_free_idents = Function_decls.all_free_idents function_declarations in let close_one_function map decl = let body = Function_decl.body decl in - let dbg = - (* Move any debugging event that may exist at the start of the function - body onto the function declaration itself. *) - match body with - | Levent (_, ({ lev_kind = Lev_function } as ev)) -> - Debuginfo.from_call ev - | _ -> Debuginfo.none - in + let loc = Function_decl.loc decl in + let dbg = Debuginfo.from_location loc in let params = Function_decl.params decl in (* Create fresh variables for the elements of the closure (cf. the comment on [Function_decl.closure_env_without_parameters], above). @@ -596,14 +635,14 @@ and close_list t sb l = List.map (close t sb) l and close_let_bound_expression t ?let_rec_ident let_bound_var env (lam : Lambda.lambda) : Flambda.named = match lam with - | Lfunction { kind; params; body; attr; } -> + | Lfunction { kind; params; body; attr; loc; } -> (* Ensure that [let] and [let rec]-bound functions have appropriate names. *) let closure_bound_var = Variable.rename let_bound_var in let decl = Function_decl.create ~let_rec_ident ~closure_bound_var ~kind ~params ~body ~inline:attr.inline ~specialise:attr.specialise - ~is_a_functor:attr.is_a_functor + ~is_a_functor:attr.is_a_functor ~loc in let set_of_closures_var = Variable.rename let_bound_var ~append:"_set_of_closures" @@ -631,6 +670,7 @@ let lambda_to_flambda ~backend ~module_ident ~size ~filename lam symbol_for_global' = Backend.symbol_for_global'; filename; imported_symbols = Symbol.Set.empty; + declared_symbols = []; } in let module_symbol = Backend.symbol_for_global' module_ident in @@ -667,6 +707,13 @@ let lambda_to_flambda ~backend ~module_ident ~size ~filename lam Array.to_list fields, End module_symbol)) in + let program_body = + List.fold_left + (fun program_body (symbol, constant) : Flambda.program_body -> + Let_symbol (symbol, constant, program_body)) + module_initializer + t.declared_symbols + in { imported_symbols = t.imported_symbols; - program_body = module_initializer; + program_body; } diff --git a/middle_end/closure_conversion_aux.ml b/middle_end/closure_conversion_aux.ml index d6270580..becac905 100644 --- a/middle_end/closure_conversion_aux.ml +++ b/middle_end/closure_conversion_aux.ml @@ -96,10 +96,11 @@ module Function_decls = struct inline : Lambda.inline_attribute; specialise : Lambda.specialise_attribute; is_a_functor : bool; + loc : Location.t; } let create ~let_rec_ident ~closure_bound_var ~kind ~params ~body ~inline - ~specialise ~is_a_functor = + ~specialise ~is_a_functor ~loc = let let_rec_ident = match let_rec_ident with | None -> Ident.create "unnamed_function" @@ -114,6 +115,7 @@ module Function_decls = struct inline; specialise; is_a_functor; + loc; } let let_rec_ident t = t.let_rec_ident @@ -125,10 +127,11 @@ module Function_decls = struct let inline t = t.inline let specialise t = t.specialise let is_a_functor t = t.is_a_functor + let loc t = t.loc let primitive_wrapper t = match t.body with - | Lprim (Pccall { Primitive. prim_name; }, [body]) + | Lprim (Pccall { Primitive. prim_name; }, [body], _) when prim_name = stub_hack_prim_name -> Some body | _ -> None end diff --git a/middle_end/closure_conversion_aux.mli b/middle_end/closure_conversion_aux.mli old mode 100644 new mode 100755 index b5c84dc6..b51ef52a --- a/middle_end/closure_conversion_aux.mli +++ b/middle_end/closure_conversion_aux.mli @@ -61,6 +61,7 @@ module Function_decls : sig -> inline:Lambda.inline_attribute -> specialise:Lambda.specialise_attribute -> is_a_functor:bool + -> loc:Location.t -> t val let_rec_ident : t -> Ident.t @@ -71,9 +72,10 @@ module Function_decls : sig val inline : t -> Lambda.inline_attribute val specialise : t -> Lambda.specialise_attribute val is_a_functor : t -> bool + val loc : t -> Location.t (* [primitive_wrapper t] is [None] iff [t] is not a wrapper for a function - with default optionnal arguments. Otherwise it is [Some body], where + with default optional arguments. Otherwise it is [Some body], where [body] is the body of the wrapper. *) val primitive_wrapper : t -> Lambda.lambda option diff --git a/middle_end/debuginfo.ml b/middle_end/debuginfo.ml new file mode 100644 index 00000000..a93f4258 --- /dev/null +++ b/middle_end/debuginfo.ml @@ -0,0 +1,96 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Lexing +open Location + +type item = { + dinfo_file: string; + dinfo_line: int; + dinfo_char_start: int; + dinfo_char_end: int; +} + +type t = item list + +let none = [] + +let is_none = function + | [] -> true + | _ :: _ -> false + +let to_string dbg = + match dbg with + | [] -> "" + | ds -> + let items = + List.map + (fun d -> + Printf.sprintf "%s:%d,%d-%d" + d.dinfo_file d.dinfo_line d.dinfo_char_start d.dinfo_char_end) + ds + in + "{" ^ String.concat ";" items ^ "}" + +let item_from_location loc = + { dinfo_file = loc.loc_start.pos_fname; + dinfo_line = loc.loc_start.pos_lnum; + dinfo_char_start = loc.loc_start.pos_cnum - loc.loc_start.pos_bol; + dinfo_char_end = + if loc.loc_end.pos_fname = loc.loc_start.pos_fname + then loc.loc_end.pos_cnum - loc.loc_start.pos_bol + else loc.loc_start.pos_cnum - loc.loc_start.pos_bol; + } + +let from_location loc = + if loc == Location.none then [] else [item_from_location loc] + +let to_location = function + | [] -> Location.none + | d :: _ -> + let loc_start = + { pos_fname = d.dinfo_file; + pos_lnum = d.dinfo_line; + pos_bol = 0; + pos_cnum = d.dinfo_char_start; + } in + let loc_end = { loc_start with pos_cnum = d.dinfo_char_end; } in + { loc_ghost = false; loc_start; loc_end; } + +let inline loc t = + if loc == Location.none then t + else (item_from_location loc) :: t + +let concat dbg1 dbg2 = + dbg1 @ dbg2 + +let compare dbg1 dbg2 = + let rec loop ds1 ds2 = + match ds1, ds2 with + | [], [] -> 0 + | _ :: _, [] -> 1 + | [], _ :: _ -> -1 + | d1 :: ds1, d2 :: ds2 -> + let c = compare d1.dinfo_file d2.dinfo_file in + if c <> 0 then c else + let c = compare d1.dinfo_line d2.dinfo_line in + if c <> 0 then c else + let c = compare d1.dinfo_char_end d2.dinfo_char_end in + if c <> 0 then c else + let c = compare d1.dinfo_char_start d2.dinfo_char_start in + if c <> 0 then c else + loop ds1 ds2 + in + loop (List.rev dbg1) (List.rev dbg2) diff --git a/middle_end/debuginfo.mli b/middle_end/debuginfo.mli new file mode 100644 index 00000000..993928c0 --- /dev/null +++ b/middle_end/debuginfo.mli @@ -0,0 +1,39 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type item = private { + dinfo_file: string; + dinfo_line: int; + dinfo_char_start: int; + dinfo_char_end: int +} + +type t = item list + +val none : t + +val is_none : t -> bool + +val to_string : t -> string + +val from_location : Location.t -> t + +val to_location : t -> Location.t + +val concat: t -> t -> t + +val inline: Location.t -> t -> t + +val compare : t -> t -> int diff --git a/middle_end/effect_analysis.ml b/middle_end/effect_analysis.ml index a8c7ccb9..011dee47 100644 --- a/middle_end/effect_analysis.ml +++ b/middle_end/effect_analysis.ml @@ -27,7 +27,7 @@ let rec no_effects (flam : Flambda.t) = | Var _ -> true | Let { defining_expr; body; _ } -> no_effects_named defining_expr && no_effects body - | Let_mutable (_, _, body) -> no_effects body + | Let_mutable { body } -> no_effects body | Let_rec (defs, body) -> no_effects body && List.for_all (fun (_, def) -> no_effects_named def) defs diff --git a/middle_end/extract_projections.ml b/middle_end/extract_projections.ml index e8171f8a..e00dd6de 100644 --- a/middle_end/extract_projections.ml +++ b/middle_end/extract_projections.ml @@ -83,7 +83,7 @@ let rec analyse_expr ~which_variables expr = let for_expr (expr : Flambda.expr) = match expr with | Var var - | Let_mutable (_, var, _) -> + | Let_mutable { initial_value = var } -> check_free_variable var (* CR-soon mshinwell: We don't handle [Apply] for the moment to avoid disabling unboxing optimizations whenever we see a recursive diff --git a/middle_end/flambda.ml b/middle_end/flambda.ml index bbc66382..b26de62e 100644 --- a/middle_end/flambda.ml +++ b/middle_end/flambda.ml @@ -59,7 +59,7 @@ type specialised_to = { type t = | Var of Variable.t | Let of let_expr - | Let_mutable of Mutable_variable.t * Variable.t * t + | Let_mutable of let_mutable | Let_rec of (Variable.t * named) list * t | Apply of apply | Send of send @@ -95,6 +95,13 @@ and let_expr = { free_vars_of_body : Variable.Set.t; } +and let_mutable = { + var : Mutable_variable.t; + initial_value : Variable.t; + contents_kind : Lambda.value_kind; + body : t; +} + and set_of_closures = { function_decls : function_declarations; free_vars : specialised_to Variable.Map.t; @@ -182,7 +189,7 @@ let rec lam ppf (flam : t) = match flam with | Var (id) -> Variable.print ppf id - | Apply({func; args; kind; inline}) -> + | Apply({func; args; kind; inline; dbg}) -> let direct ppf () = match kind with | Indirect -> () @@ -195,7 +202,8 @@ let rec lam ppf (flam : t) = | Unroll i -> fprintf ppf "" i | Default_inline -> () in - fprintf ppf "@[<2>(apply%a%a@ %a%a)@]" direct () inline () + fprintf ppf "@[<2>(apply%a%a<%s>@ %a%a)@]" direct () inline () + (Debuginfo.to_string dbg) Variable.print func Variable.print_list args | Assign { being_assigned; new_value; } -> fprintf ppf "@[<2>(assign@ %a@ %a)@]" @@ -228,8 +236,14 @@ let rec lam ppf (flam : t) = Variable.print id print_named arg; let expr = letbody body in fprintf ppf ")@]@ %a)@]" lam expr - | Let_mutable (mut_var, var, body) -> - fprintf ppf "@[<2>(let_mutable@ @[<2>%a@ %a@]@ %a)@]" + | Let_mutable { var = mut_var; initial_value = var; body; contents_kind } -> + let print_kind ppf (kind : Lambda.value_kind) = + match kind with + | Pgenval -> () + | _ -> Format.fprintf ppf " %s" (Printlambda.value_kind kind) + in + fprintf ppf "@[<2>(let_mutable%a@ @[<2>%a@ %a@]@ %a)@]" + print_kind contents_kind Mutable_variable.print mut_var Variable.print var lam body @@ -330,8 +344,9 @@ and print_named ppf (named : named) = print_move_within_set_of_closures ppf move_within_set_of_closures | Set_of_closures (set_of_closures) -> print_set_of_closures ppf set_of_closures - | Prim(prim, args, _) -> - fprintf ppf "@[<2>(%a%a)@]" Printlambda.primitive prim + | Prim(prim, args, dbg) -> + fprintf ppf "@[<2>(%a<%s>%a)@]" Printlambda.primitive prim + (Debuginfo.to_string dbg) Variable.print_list args | Expr expr -> fprintf ppf "*%a" lam expr @@ -479,7 +494,7 @@ let rec print_program_body ppf (program : program_body) = (Format.pp_print_list lam) fields; print_program_body ppf program | Effect (expr, program) -> - fprintf ppf "@[effect @[%a@]@@]@." + fprintf ppf "@[effect @[%a@]@]@." lam expr; print_program_body ppf program; | End root -> fprintf ppf "End %a" Symbol.print root @@ -532,7 +547,7 @@ let rec variables_usage ?ignore_uses_as_callee ?ignore_uses_as_argument free_variables free_vars_of_defining_expr; free_variables free_vars_of_body end - | Let_mutable (_mut_var, var, body) -> + | Let_mutable { initial_value = var; body; _ } -> free_variable var; aux body | Let_rec (bindings, body) -> @@ -756,7 +771,7 @@ let iter_general ~toplevel f f_named maybe_named = | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable | Static_raise _ -> () | Let _ -> assert false - | Let_mutable (_mut_var, _var, body) -> + | Let_mutable { body; _ } -> aux body | Let_rec (defs, body) -> List.iter (fun (_,l) -> aux_named l) defs; diff --git a/middle_end/flambda.mli b/middle_end/flambda.mli old mode 100644 new mode 100755 index 6e8ede86..6826e9ee --- a/middle_end/flambda.mli +++ b/middle_end/flambda.mli @@ -96,7 +96,7 @@ type specialised_to = { type t = | Var of Variable.t | Let of let_expr - | Let_mutable of Mutable_variable.t * Variable.t * t + | Let_mutable of let_mutable | Let_rec of (Variable.t * named) list * t (** CR-someday lwhite: give Let_rec the same fields as Let. *) | Apply of apply @@ -179,6 +179,13 @@ and let_expr = private { important optimization. *) } +and let_mutable = { + var : Mutable_variable.t; + initial_value : Variable.t; + contents_kind : Lambda.value_kind; + body : t; +} + (** The representation of a set of function declarations (possibly mutually recursive). Such a set encapsulates the declarations themselves, information about their defining environment, and information used @@ -242,7 +249,7 @@ and set_of_closures = private { [let rec f a b c = f a 1 2 in], [a] -> [x] would still be a valid specialised argument because all recursive calls maintain the invariant. - This information is used for optimisation purposes, if such a binding is + This information is used for optimization purposes, if such a binding is known, it is possible to specialise the body of the function according to its parameter. This is usually introduced when specialising a recursive function, for instance. @@ -427,7 +434,7 @@ val free_variables_named -> named -> Variable.Set.t -(** Compute _all_ variables occuring inside an expression. *) +(** Compute _all_ variables occurring 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 old mode 100644 new mode 100755 index b007a425..bde0b881 --- a/middle_end/flambda_invariants.ml +++ b/middle_end/flambda_invariants.ml @@ -50,6 +50,7 @@ let ignore_var_within_closure (_ : Var_within_closure.t) = () let ignore_tag (_ : Tag.t) = () let ignore_inline_attribute (_ : Lambda.inline_attribute) = () let ignore_specialise_attribute (_ : Lambda.specialise_attribute) = () +let ignore_value_kind (_ : Lambda.value_kind) = () exception Binding_occurrence_not_from_current_compilation_unit of Variable.t exception Mutable_binding_occurrence_not_from_current_compilation_unit of @@ -157,7 +158,9 @@ let variable_and_symbol_invariants (program : Flambda.program) = | Let { var; defining_expr; body; _ } -> loop_named env defining_expr; loop (add_binding_occurrence env var) body - | Let_mutable (mut_var, var, body) -> + | Let_mutable { var = mut_var; initial_value = var; + body; contents_kind } -> + ignore_value_kind contents_kind; check_variable_is_bound env var; loop (add_mutable_binding_occurrence env mut_var) body | Let_rec (defs, body) -> @@ -359,7 +362,7 @@ let variable_and_symbol_invariants (program : Flambda.program) = (* CR-someday pchambart: Ignore it to avoid the warning: get rid of that when the case is settled *) ignore (Set_of_closures_free_vars_map_has_wrong_range bad_free_vars); - (* Check that free variables variables are not bound somewhere + (* Check that free variables are not bound somewhere else in the program *) declare_variables (Variable.Map.keys free_vars); (* Check that every "specialised arg" is a parameter of one of the @@ -463,8 +466,8 @@ let primitive_invariants flam ~no_access_to_global_module_identifiers = raise (Access_to_global_module_identifier prim) end | Pidentity -> raise Pidentity_should_not_occur - | Pdirapply _ -> raise Pdirapply_should_be_expanded - | Prevapply _ -> raise Prevapply_should_be_expanded + | Pdirapply -> raise Pdirapply_should_be_expanded + | Prevapply -> raise Prevapply_should_be_expanded | _ -> () end | _ -> ()) diff --git a/middle_end/flambda_iterators.ml b/middle_end/flambda_iterators.ml index 170e87ed..709ccc67 100644 --- a/middle_end/flambda_iterators.ml +++ b/middle_end/flambda_iterators.ml @@ -23,7 +23,7 @@ let apply_on_subexpressions f f_named (flam : Flambda.t) = | Let { defining_expr; body; _ } -> f_named defining_expr; f body - | Let_mutable (_mut_var, _var, body) -> + | Let_mutable { body; _ } -> f body | Let_rec (defs, body) -> List.iter (fun (_,l) -> f_named l) defs; @@ -93,12 +93,12 @@ let map_subexpressions f f_named (tree:Flambda.t) : Flambda.t = tree else Let_rec (new_defs, new_body) - | Let_mutable (mut_var, var, body) -> - let new_body = f body in - if new_body == body then + | Let_mutable mutable_let -> + let new_body = f mutable_let.body in + if new_body == mutable_let.body then tree else - Let_mutable (mut_var, var, new_body) + Let_mutable { mutable_let with body = new_body } | Switch (arg, sw) -> let aux = map_snd_sharing (fun _ v -> f v) in let new_consts = list_map_sharing aux sw.consts in @@ -292,12 +292,12 @@ let map_general ~toplevel f f_named tree = | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable | Static_raise _ -> tree | Let _ -> assert false - | Let_mutable (mut_var, var, body) -> - let new_body = aux body in - if new_body == body then + | Let_mutable mutable_let -> + let new_body = aux mutable_let.body in + if new_body == mutable_let.body then tree else - Let_mutable (mut_var, var, new_body) + Let_mutable { mutable_let with body = new_body } | Let_rec (defs, body) -> let done_something = ref false in let defs = diff --git a/middle_end/flambda_utils.ml b/middle_end/flambda_utils.ml index 3f97455f..14a9eafe 100644 --- a/middle_end/flambda_utils.ml +++ b/middle_end/flambda_utils.ml @@ -95,9 +95,12 @@ let rec same (l1 : Flambda.t) (l2 : Flambda.t) = Variable.equal var1 var2 && same_named defining_expr1 defining_expr2 && same body1 body2 | Let _, _ | _, Let _ -> false - | Let_mutable (mv1, v1, b1), Let_mutable (mv2, v2, b2) -> + | Let_mutable {var = mv1; initial_value = v1; contents_kind = ck1; body = b1}, + Let_mutable {var = mv2; initial_value = v2; contents_kind = ck2; body = b2} + -> Mutable_variable.equal mv1 mv2 && Variable.equal v1 v2 + && ck1 = ck2 && same b1 b2 | Let_mutable _, _ | _, Let_mutable _ -> false | Let_rec (bl1, a1), Let_rec (bl2, a2) -> @@ -232,9 +235,9 @@ let toplevel_substitution sb tree = | Var var -> let var = sb var in Var var - | Let_mutable (mut_var, var, body) -> - let var = sb var in - Let_mutable (mut_var, var, body) + | Let_mutable mutable_let -> + let initial_value = sb mutable_let.initial_value in + Let_mutable { mutable_let with initial_value } | Assign { being_assigned; new_value; } -> let new_value = sb new_value in Assign { being_assigned; new_value; } @@ -633,10 +636,12 @@ let substitute_read_symbol_field_for_variables Variable.Map.fold (fun to_substitute fresh expr -> bind to_substitute fresh expr) bindings expr - | Let_mutable (mut_var, var, body) when Variable.Map.mem var substitution -> - let fresh = Variable.rename var in - bind var fresh (Let_mutable (mut_var, fresh, body)) - | Let_mutable (_mut_var, _var, _body) -> + | Let_mutable let_mutable when + Variable.Map.mem let_mutable.initial_value substitution -> + let fresh = Variable.rename let_mutable.initial_value in + bind let_mutable.initial_value fresh + (Let_mutable { let_mutable with initial_value = fresh }) + | Let_mutable _ -> expr | Let_rec (defs, body) -> let free_variables_of_defs = @@ -834,3 +839,27 @@ let projection_to_named (projection : Projection.t) : Flambda.named = | Move_within_set_of_closures move -> Move_within_set_of_closures move | Field (field_index, var) -> Prim (Pfield field_index, [var], Debuginfo.none) + +type specialised_to_same_as = + | Not_specialised + | Specialised_and_aliased_to of Variable.Set.t + +let parameters_specialised_to_the_same_variable + ~(function_decls : Flambda.function_declarations) + ~(specialised_args : Flambda.specialised_to Variable.Map.t) = + let specialised_arg_aliasing = + (* For each external variable involved in a specialisation, which + internal variable(s) it maps to via that specialisation. *) + Variable.Map.transpose_keys_and_data_set + (Variable.Map.map (fun ({ var; _ } : Flambda.specialised_to) -> var) + specialised_args) + in + Variable.Map.map (fun ({ params; _ } : Flambda.function_declaration) -> + List.map (fun param -> + match Variable.Map.find param specialised_args with + | exception Not_found -> Not_specialised + | { var; _ } -> + Specialised_and_aliased_to + (Variable.Map.find var specialised_arg_aliasing)) + params) + function_decls.funs diff --git a/middle_end/flambda_utils.mli b/middle_end/flambda_utils.mli index aba0bdb1..d9030d83 100644 --- a/middle_end/flambda_utils.mli +++ b/middle_end/flambda_utils.mli @@ -214,3 +214,18 @@ val clean_projections -> Flambda.specialised_to Variable.Map.t val projection_to_named : Projection.t -> Flambda.named + +type specialised_to_same_as = + | Not_specialised + | Specialised_and_aliased_to of Variable.Set.t + +(** For each parameter in a given set of function declarations and the usual + specialised-args mapping, determine which other parameters are specialised + to the same variable as that parameter. + The result is presented as a map from [fun_vars] to lists, corresponding + componentwise to the usual [params] list in the corresponding function + declaration. *) +val parameters_specialised_to_the_same_variable + : function_decls:Flambda.function_declarations + -> specialised_args:Flambda.specialised_to Variable.Map.t + -> specialised_to_same_as list Variable.Map.t diff --git a/middle_end/inconstant_idents.ml b/middle_end/inconstant_idents.ml old mode 100644 new mode 100755 index 04921800..dc0b3e2c --- a/middle_end/inconstant_idents.ml +++ b/middle_end/inconstant_idents.ml @@ -49,7 +49,7 @@ (* CR-someday lwhite: I think this pass could be combined with alias_analysis and other parts of lift_constants into a single - type-based anaylsis which infers a "type" for each variable that is + type-based analysis which infers a "type" for each variable that is either an allocated_constant expression or "not constant". Recursion would be handled with unification variables. *) @@ -216,7 +216,7 @@ module Inconstants (P:Param) (Backend:Backend_intf.S) = struct (* First loop: iterates on the tree to mark dependencies. - curr is the variables or closures to wich we add constraints like + curr is the variables or closures to which we add constraints like '... in NC => curr in NC' or 'curr in NC' It can be empty when no constraint can be added like in the toplevel @@ -231,7 +231,7 @@ module Inconstants (P:Param) (Backend:Backend_intf.S) = struct trickier than eliminating that earlier. *) mark_var var curr; mark_loop ~toplevel curr body - | Let_mutable (_mut_var, var, body) -> + | Let_mutable { initial_value = var; body } -> mark_var var curr; mark_loop ~toplevel curr body | Let_rec(defs, body) -> @@ -336,7 +336,8 @@ module Inconstants (P:Param) (Backend:Backend_intf.S) = struct makeblock(Mutable) can be a 'constant' if it is allocated at toplevel: if this expression is evaluated only once. *) - | Prim (Lambda.Pmakeblock (_tag, Asttypes.Immutable), args, _dbg) -> + | Prim (Lambda.Pmakeblock (_tag, Asttypes.Immutable, _value_kind), args, + _dbg) -> mark_vars args curr (* (* CR-someday pchambart: If global mutables are allowed: *) | Prim(Lambda.Pmakeblock(_tag, Asttypes.Mutable), args, _dbg, _) @@ -346,6 +347,14 @@ module Inconstants (P:Param) (Backend:Backend_intf.S) = struct | Prim (Pmakearray (Pfloatarray, Immutable), args, _) -> mark_vars args curr | Prim (Pmakearray (Pfloatarray, Mutable), args, _) -> + (* CR-someday pchambart: Toplevel float arrays could always be + statically allocated using an equivalent of the + Initialize_symbol construction. + Toplevel non-float arrays could also be turned into an + Initialize_symbol, but only when declared as immutable since + preallocated symbols does not allow mutation after + initialisation + *) if toplevel then mark_vars args curr else mark_curr curr | Prim (Pduparray (Pfloatarray, Immutable), [arg], _) -> diff --git a/middle_end/inline_and_simplify.ml b/middle_end/inline_and_simplify.ml old mode 100644 new mode 100755 index 1ce8fe2b..75b47a1a --- a/middle_end/inline_and_simplify.ml +++ b/middle_end/inline_and_simplify.ml @@ -185,7 +185,11 @@ let approx_for_allocated_const (const : Allocated_const.t) = | Float_array a -> A.value_mutable_float_array ~size:(List.length a) | Immutable_float_array a -> A.value_immutable_float_array - (Array.map (fun x -> Some x) (Array.of_list a)) + (Array.map A.value_float (Array.of_list a)) + +type filtered_switch_branches = + | Must_be_taken of Flambda.t + | Can_be_taken of (int * Flambda.t) list (* Determine whether a given closure ID corresponds directly to a variable (bound to a closure) in the given environment. This happens when the body @@ -422,7 +426,7 @@ let simplify_move_within_set_of_closures env r If the function is declared outside of the alpha renamed part, there is no need for renaming in the [Ffunction] and [Project_var]. - This is not usualy the case, except when the closure declaration is a + This is not usually the case, except when the closure declaration is a symbol. What ensures that this information is available at [Project_var] @@ -554,7 +558,7 @@ let rec simplify_project_var env r ~(project_var : Flambda.project_var) will be introduced in the current scope for [y_1] each time. - If the function where a recursive one comming from another compilation + If the function where a recursive one coming from another compilation unit, the code already went through [Flambdasym] that could have replaced the function variable by the symbol identifying the function (this occur if the function contains only constants in its closure). @@ -593,7 +597,7 @@ and simplify_set_of_closures original_env r E.enter_closure closure_env ~closure_id:(Closure_id.wrap fun_var) ~inline_inside: (Inlining_decision.should_inline_inside_declaration function_decl) - ~debuginfo:function_decl.dbg + ~dbg:function_decl.dbg ~f:(fun body_env -> simplify body_env r function_decl.body) in let inline : Lambda.inline_attribute = @@ -668,6 +672,7 @@ and simplify_apply env r ~(apply : Flambda.apply) : Flambda.t * R.t = Flambda. func = lhs_of_application; args; kind = _; dbg; inline = inline_requested; specialise = specialise_requested; } = apply in + let dbg = E.add_inlined_debuginfo env ~dbg in simplify_free_variable env lhs_of_application ~f:(fun env lhs_of_application lhs_of_application_approx -> simplify_free_variables env args ~f:(fun env args args_approxs -> @@ -978,6 +983,7 @@ and simplify_named env r (tree : Flambda.named) : Flambda.named * R.t = | Move_within_set_of_closures move_within_set_of_closures -> simplify_move_within_set_of_closures env r ~move_within_set_of_closures | Prim (prim, args, dbg) -> + let dbg = E.add_inlined_debuginfo env ~dbg in simplify_free_variables_named env args ~f:(fun env args args_approxs -> let tree = Flambda.Prim (prim, args, dbg) in begin match prim, args, args_approxs with @@ -1006,16 +1012,43 @@ and simplify_named env r (tree : Flambda.named) : Flambda.named * R.t = | None | Some (_, Some _ ) -> (* This [Pfield] is either not projecting from a symbol at all, or it is the projection of a projection from a symbol. *) - let module Backend = (val (E.backend env) : Backend_intf.S) in - let approx' = Backend.really_import_approx approx in + let approx' = E.really_import_approx env approx in tree, approx' in simplify_named_using_approx_and_env env r tree approx end end | Pfield _, _, _ -> Misc.fatal_error "Pfield arity error" - | (Psetfield _ | Parraysetu _ | Parraysets _), - _block::_, block_approx::_ -> + | (Parraysetu kind | Parraysets kind), + [_block; _field; _value], + [block_approx; _field_approx; value_approx] -> + if A.is_definitely_immutable block_approx then begin + Location.prerr_warning (Debuginfo.to_location dbg) + Warnings.Assignment_to_non_mutable_value + end; + let kind = match A.descr block_approx, A.descr value_approx with + | (Value_float_array _, _) + | (_, Value_float _) -> + begin match kind with + | Pfloatarray | Pgenarray -> () + | Paddrarray | Pintarray -> + (* CR pchambart: Do a proper warning here *) + Misc.fatal_errorf "Assignment of a float to a specialised \ + non-float array: %a" + Flambda.print_named tree + end; + Lambda.Pfloatarray + (* CR pchambart: This should be accounted by the benefit *) + | _ -> + kind + in + let prim : Lambda.primitive = match prim with + | Parraysetu _ -> Parraysetu kind + | Parraysets _ -> Parraysets kind + | _ -> assert false + in + Prim (prim, args, dbg), ret r (A.value_unknown Other) + | Psetfield _, _block::_, block_approx::_ -> if A.is_definitely_immutable block_approx then begin Location.prerr_warning (Debuginfo.to_location dbg) Warnings.Assignment_to_non_mutable_value @@ -1081,7 +1114,7 @@ and simplify env r (tree : Flambda.t) : Flambda.t * R.t = ~for_defining_expr ~for_last_body ~filter_defining_expr - | Let_mutable (mut_var, var, body) -> + | Let_mutable { var = mut_var; initial_value = var; body; contents_kind } -> (* CR-someday mshinwell: add the dead let elimination, as above. *) simplify_free_variable env var ~f:(fun env var _var_approx -> let mut_var, sb = @@ -1091,7 +1124,12 @@ and simplify env r (tree : Flambda.t) : Flambda.t * R.t = let body, r = simplify (E.add_mutable env mut_var (A.value_unknown Other)) r body in - Flambda.Let_mutable (mut_var, var, body), r) + Flambda.Let_mutable + { var = mut_var; + initial_value = var; + body; + contents_kind }, + r) | Let_rec (defs, body) -> let defs, sb = Freshening.add_variables (E.freshening env) defs in let env = E.set_freshening env sb in @@ -1144,6 +1182,7 @@ and simplify env r (tree : Flambda.t) : Flambda.t * R.t = simplify env r handler | _ -> let vars, sb = Freshening.add_variables' (E.freshening env) vars in + let approx = R.approx r in let env = List.fold_left (fun env id -> E.add env id (A.value_unknown Other)) @@ -1153,7 +1192,7 @@ and simplify env r (tree : Flambda.t) : Flambda.t * R.t = let handler, r = simplify env r handler in let r = R.exit_scope_catch r i in Static_catch (i, vars, body, handler), - ret r (A.value_unknown Other) + R.meet_approx r env approx end end | Try_with (body, id, handler) -> @@ -1181,15 +1220,15 @@ and simplify env r (tree : Flambda.t) : Flambda.t * R.t = let ifso, r = simplify env r ifso in let ifso_approx = R.approx r in let ifnot, r = simplify env r ifnot in - let ifnot_approx = R.approx r in If_then_else (arg, ifso, ifnot), - ret r (A.meet ifso_approx ifnot_approx) + R.meet_approx r env ifso_approx end) | While (cond, body) -> let cond, r = simplify env r cond in let body, r = simplify env r body in While (cond, body), ret r (A.value_unknown Other) | Send { kind; meth; obj; args; dbg; } -> + let dbg = E.add_inlined_debuginfo env ~dbg in simplify_free_variable env meth ~f:(fun env meth _meth_approx -> simplify_free_variable env obj ~f:(fun env obj _obj_approx -> simplify_free_variables env args ~f:(fun _env args _args_approx -> @@ -1222,7 +1261,34 @@ and simplify env r (tree : Flambda.t) : Flambda.t * R.t = [Switch]. (This should also make the [Let] that binds [arg] redundant, meaning that it too can be eliminated.) *) simplify_free_variable env arg ~f:(fun env arg arg_approx -> - let get_failaction () : Flambda.t = + let rec filter_branches filter branches compatible_branches = + match branches with + | [] -> Can_be_taken compatible_branches + | (c, lam) as branch :: branches -> + match filter arg_approx c with + | A.Cannot_be_taken -> + filter_branches filter branches compatible_branches + | A.Can_be_taken -> + filter_branches filter branches (branch :: compatible_branches) + | A.Must_be_taken -> + Must_be_taken lam + in + let filtered_consts = + filter_branches A.potentially_taken_const_switch_branch sw.consts [] + in + let filtered_blocks = + filter_branches A.potentially_taken_block_switch_branch sw.blocks [] + in + begin match filtered_consts, filtered_blocks with + | Must_be_taken _, Must_be_taken _ -> + assert false + | Must_be_taken branch, _ + | _, Must_be_taken branch -> + let lam, r = simplify env r branch in + lam, R.map_benefit r B.remove_branch + | Can_be_taken consts, Can_be_taken blocks -> + match consts, blocks, sw.failaction with + | [], [], None -> (* If the switch is applied to a statically-known value that does not match any case: * if there is a default action take that case; @@ -1235,65 +1301,72 @@ and simplify env r (tree : Flambda.t) : Flambda.t * R.t = match v with <-- This match is unreachable | Float f -> ...] *) - match sw.failaction with - | None -> Proved_unreachable - | Some f -> f - in - begin match arg_approx.descr with - | Value_int i - | Value_constptr i -> - let lam = - try List.assoc i sw.consts - with Not_found -> get_failaction () - in - let lam, r = simplify env r lam in - lam, R.map_benefit r B.remove_branch - | Value_block (tag, _) -> - let tag = Tag.to_int tag in - let lam = - try List.assoc tag sw.blocks - with Not_found -> get_failaction () - in - let lam, r = simplify env r lam in - lam, R.map_benefit r B.remove_branch - | _ -> + Proved_unreachable, ret r A.value_bottom + | [_, branch], [], None + | [], [_, branch], None + | [], [], Some branch -> + let lam, r = simplify env r branch in + lam, R.map_benefit r B.remove_branch + | _ -> + let env = E.inside_branch env in + let f (i, v) (acc, r) = + let approx = R.approx r in + let lam, r = simplify env r v in + (i, lam)::acc, + R.meet_approx r env approx + in + let r = R.set_approx r A.value_bottom in + let consts, r = List.fold_right f consts ([], r) in + let blocks, r = List.fold_right f blocks ([], r) in + let failaction, r = + match sw.failaction with + | None -> None, r + | Some l -> + let approx = R.approx r in + let l, r = simplify env r l in + Some l, + R.meet_approx r env approx + in + let sw = { sw with failaction; consts; blocks; } in + Switch (arg, sw), r + end) + | String_switch (arg, sw, def) -> + simplify_free_variable env arg ~f:(fun env arg arg_approx -> + match A.check_approx_for_string arg_approx with + | None -> let env = E.inside_branch env in - let f (i, v) (acc, r) = - let approx = R.approx r in - let lam, r = simplify env r v in - ((i, lam)::acc, R.set_approx r (A.meet (R.approx r) approx)) + let sw, r = + List.fold_right (fun (str, lam) (sw, r) -> + let approx = R.approx r in + let lam, r = simplify env r lam in + (str, lam)::sw, + R.meet_approx r env approx) + sw + ([], r) in - let r = R.set_approx r A.value_bottom in - let consts, r = List.fold_right f sw.consts ([], r) in - let blocks, r = List.fold_right f sw.blocks ([], r) in - let failaction, r = - match sw.failaction with - | None -> None, r - | Some l -> + let def, r = + match def with + | None -> def, r + | Some def -> let approx = R.approx r in - let l, r = simplify env r l in - Some l, R.set_approx r (A.meet (R.approx r) approx) + let def, r = simplify env r def in + Some def, + R.meet_approx r env approx in - let sw = { sw with failaction; consts; blocks; } in - Switch (arg, sw), r - end) - | String_switch (arg, sw, def) -> - simplify_free_variable env arg ~f:(fun env arg _arg_approx -> - let sw, r = - List.fold_right (fun (str, lam) (sw, r) -> - let lam, r = simplify env r lam in - (str, lam)::sw, r) - sw - ([], r) - in - let def, r = - match def with - | None -> def, r - | Some def -> - let def, r = simplify env r def in - Some def, r - in - String_switch (arg, sw, def), ret r (A.value_unknown Other)) + String_switch (arg, sw, def), ret r (A.value_unknown Other) + | Some arg_string -> + let branch = + match List.find (fun (str, _) -> str = arg_string) sw with + | (_, branch) -> branch + | exception Not_found -> + match def with + | None -> + Flambda.Proved_unreachable + | Some def -> + def + in + let branch, r = simplify env r branch in + branch, R.map_benefit r B.remove_branch) | Proved_unreachable -> tree, ret r A.value_bottom and simplify_list env r l = @@ -1339,7 +1412,7 @@ and duplicate_function ~env ~(set_of_closures : Flambda.set_of_closures) E.enter_closure closure_env ~closure_id:(Closure_id.wrap fun_var) ~inline_inside:false - ~debuginfo:function_decl.dbg + ~dbg:function_decl.dbg ~f:(fun body_env -> simplify body_env (R.create ()) function_decl.body) in @@ -1582,7 +1655,7 @@ let run ~never_inline ~backend ~prefixname ~round program = let result = Flambda_utils.introduce_needed_import_symbols result in if not (Static_exception.Set.is_empty (R.used_static_exceptions r)) then begin - Misc.fatal_error (Format.asprintf "remaining static exceptions: %a@.%a@." + Misc.fatal_error (Format.asprintf "Remaining static exceptions: %a@.%a@." Static_exception.Set.print (R.used_static_exceptions r) Flambda.print_program result) end; diff --git a/middle_end/inline_and_simplify_aux.ml b/middle_end/inline_and_simplify_aux.ml index 4f49a2fc..f853d451 100644 --- a/middle_end/inline_and_simplify_aux.ml +++ b/middle_end/inline_and_simplify_aux.ml @@ -41,6 +41,7 @@ module Env = struct actively_unrolling : int Set_of_closures_origin.Map.t; closure_depth : int; inlining_stats_closure_stack : Inlining_stats.Closure_stack.t; + inlined_debuginfo : Debuginfo.t; } let create ~never_inline ~backend ~round = @@ -63,6 +64,7 @@ module Env = struct closure_depth = 0; inlining_stats_closure_stack = Inlining_stats.Closure_stack.create (); + inlined_debuginfo = Debuginfo.none; } let backend t = t.backend @@ -73,6 +75,7 @@ module Env = struct approx = Variable.Map.empty; projections = Projection.Map.empty; freshening = Freshening.empty_preserving_activation_state env.freshening; + inlined_debuginfo = Debuginfo.none; } let inlining_level_up env = @@ -112,9 +115,9 @@ module Env = struct Mutable_variable.Map.add mut_var approx t.approx_mutable; } - let really_import_approx t approx = + let really_import_approx t = let module Backend = (val (t.backend) : Backend_intf.S) in - Backend.really_import_approx approx + Backend.really_import_approx let really_import_approx_with_scope t (scope, approx) = scope, really_import_approx t approx @@ -348,22 +351,22 @@ module Env = struct let freshening t = t.freshening let never_inline t = t.never_inline || t.never_inline_outside_closures - let note_entering_closure t ~closure_id ~debuginfo = + let note_entering_closure t ~closure_id ~dbg = if t.never_inline then t else { t with inlining_stats_closure_stack = Inlining_stats.Closure_stack.note_entering_closure - t.inlining_stats_closure_stack ~closure_id ~debuginfo; + t.inlining_stats_closure_stack ~closure_id ~dbg; } - let note_entering_call t ~closure_id ~debuginfo = + let note_entering_call t ~closure_id ~dbg = if t.never_inline then t else { t with inlining_stats_closure_stack = Inlining_stats.Closure_stack.note_entering_call - t.inlining_stats_closure_stack ~closure_id ~debuginfo; + t.inlining_stats_closure_stack ~closure_id ~dbg; } let note_entering_inlined t = @@ -384,17 +387,23 @@ module Env = struct t.inlining_stats_closure_stack ~closure_ids; } - let enter_closure t ~closure_id ~inline_inside ~debuginfo ~f = + let enter_closure t ~closure_id ~inline_inside ~dbg ~f = let t = if inline_inside && not t.never_inline_inside_closures then t else set_never_inline t in let t = unset_never_inline_outside_closures t in - f (note_entering_closure t ~closure_id ~debuginfo) + f (note_entering_closure t ~closure_id ~dbg) let record_decision t decision = Inlining_stats.record_decision decision ~closure_stack:t.inlining_stats_closure_stack + + let set_inline_debuginfo t ~dbg = + { t with inlined_debuginfo = dbg } + + let add_inlined_debuginfo t ~dbg = + Debuginfo.concat t.inlined_debuginfo dbg end let initial_inlining_threshold ~round : Inlining_cost.Threshold.t = @@ -423,8 +432,6 @@ let initial_inlining_toplevel_threshold ~round : Inlining_cost.Threshold.t = (unscaled * Inlining_cost.scale_inline_threshold_by) module Result = struct - module Int = Numbers.Int - type t = { approx : Simple_value_approx.t; used_static_exceptions : Static_exception.Set.t; @@ -444,6 +451,13 @@ module Result = struct let approx t = t.approx let set_approx t approx = { t with approx } + let meet_approx t env approx = + let really_import_approx = Env.really_import_approx env in + let meet = + Simple_value_approx.meet ~really_import_approx t.approx approx + in + set_approx t meet + let use_static_exception t i = { t with used_static_exceptions = diff --git a/middle_end/inline_and_simplify_aux.mli b/middle_end/inline_and_simplify_aux.mli old mode 100644 new mode 100755 index a3a581d9..a1b71c14 --- a/middle_end/inline_and_simplify_aux.mli +++ b/middle_end/inline_and_simplify_aux.mli @@ -39,6 +39,11 @@ module Env : sig compiler backend being used for compilation. *) val backend : t -> (module Backend_intf.S) + (** Obtain the really_import_approx function from the backend module. *) + val really_import_approx + : t + -> (Simple_value_approx.t -> Simple_value_approx.t) + (** Which simplification round we are currently in. *) val round : t -> int @@ -172,7 +177,7 @@ module Env : sig val inlining_level : t -> int (** Mark that this environment is used to rewrite code for inlining. This is - used by the inlining heuristics to decide wether to continue. + used by the inlining heuristics to decide whether to continue. Unconditionally inlined does not take this into account. *) val inlining_level_up : t -> t @@ -208,7 +213,7 @@ module Env : sig val note_entering_closure : t -> closure_id:Closure_id.t - -> debuginfo:Debuginfo.t + -> dbg:Debuginfo.t -> t (** If collecting inlining statistics, record that the inliner is about to @@ -218,7 +223,7 @@ module Env : sig val note_entering_call : t -> closure_id:Closure_id.t - -> debuginfo:Debuginfo.t + -> dbg:Debuginfo.t -> t (** If collecting inlining statistics, record that the inliner is about to @@ -239,7 +244,7 @@ module Env : sig : t -> closure_id:Closure_id.t -> inline_inside:bool - -> debuginfo:Debuginfo.t + -> dbg:Debuginfo.t -> f:(t -> 'a) -> 'a @@ -253,6 +258,14 @@ module Env : sig (** Print a human-readable version of the given environment. *) val print : Format.formatter -> t -> unit + + (** The environment stores the call-site being inlined to produce + precise location information. This function sets the current + call-site being inlined. *) + val set_inline_debuginfo : t -> dbg:Debuginfo.t -> t + + (** Appends the locations of inlined call-sites to the [~dbg] argument *) + val add_inlined_debuginfo : t -> dbg:Debuginfo.t -> Debuginfo.t end module Result : sig @@ -272,6 +285,12 @@ module Result : sig simplification algorithm. *) val set_approx : t -> Simple_value_approx.t -> t + (** Set the approximation of the subexpression to the meet of the + current return aprroximation and the provided one. Typically + used just before returning from a branch case of the + simplification algorithm. *) + val meet_approx : t -> Env.t -> Simple_value_approx.t -> t + (** All static exceptions for which [use_staticfail] has been called on the given result structure. *) val used_static_exceptions : t -> Static_exception.Set.t diff --git a/middle_end/inlining_cost.ml b/middle_end/inlining_cost.ml index 27f0f58e..9c049eff 100644 --- a/middle_end/inlining_cost.ml +++ b/middle_end/inlining_cost.ml @@ -39,7 +39,9 @@ let prim_size (prim : Lambda.primitive) args = | Pccall p -> (if p.Primitive.prim_alloc then 10 else 4) + List.length args | Praise _ -> 4 | Pstringlength -> 5 - | Pstringrefs | Pstringsets -> 6 + | Pbyteslength -> 5 + | Pstringrefs -> 6 + | Pbytesrefs | Pbytessets -> 6 | Pmakearray _ -> 5 + List.length args | Parraylength Pgenarray -> 6 | Parraylength _ -> 2 @@ -85,7 +87,7 @@ let lambda_smaller' lam ~than:threshold = | Let { defining_expr; body; _ } -> lambda_named_size defining_expr; lambda_size body - | Let_mutable (_, _, body) -> lambda_size body + | Let_mutable { body } -> lambda_size body | Let_rec (bindings, body) -> List.iter (fun (_, lam) -> lambda_named_size lam) bindings; lambda_size body diff --git a/middle_end/inlining_decision.ml b/middle_end/inlining_decision.ml old mode 100644 new mode 100755 index f9cf8859..730419b2 --- a/middle_end/inlining_decision.ml +++ b/middle_end/inlining_decision.ml @@ -37,7 +37,7 @@ let inline env r ~lhs_of_application ~(function_decls : Flambda.function_declarations) ~closure_id_being_applied ~(function_decl : Flambda.function_declaration) ~value_set_of_closures ~only_use_of_function ~original ~recursive - ~(args : Variable.t list) ~size_from_approximation ~simplify + ~(args : Variable.t list) ~size_from_approximation ~dbg ~simplify ~(inline_requested : Lambda.inline_attribute) ~(specialise_requested : Lambda.specialise_attribute) ~self_call ~fun_cost ~inlining_threshold = @@ -119,7 +119,7 @@ let inline env r ~lhs_of_application We may need to think a bit about that. I can't see a lot of meaningful examples right now, but there are some cases where some - optimisation can happen even if we don't know anything about the + optimization can happen even if we don't know anything about the shape of the arguments. For instance @@ -192,7 +192,7 @@ let inline env r ~lhs_of_application Inlining_transforms.inline_by_copying_function_body ~env ~r:(R.reset_benefit r) ~function_decls ~lhs_of_application ~closure_id_being_applied ~specialise_requested ~inline_requested - ~function_decl ~args ~simplify + ~function_decl ~args ~dbg ~simplify in let num_direct_applications_seen = (R.num_direct_applications r_inlined) - (R.num_direct_applications r) @@ -251,7 +251,7 @@ let inline env r ~lhs_of_application else if num_direct_applications_seen < 1 then begin (* Inlining the body of the function did not appear sufficiently beneficial; however, it may become so if we inline within the body - first. We try that next, unless it is known that there are were + first. We try that next, unless it is known that there were no direct applications in the simplified body computed above, meaning no opportunities for inlining. *) Original (S.Not_inlined.Without_subfunctions wsb) @@ -362,12 +362,12 @@ let specialise env r ~lhs_of_application - has useful approximations for some invariant parameters. *) if !Clflags.classic_inlining then Don't_try_it S.Not_specialised.Classic_mode + else if self_call then + Don't_try_it S.Not_specialised.Self_call else if always_specialise && not (Lazy.force has_no_useful_approxes) then Try_it else if never_specialise then Don't_try_it S.Not_specialised.Annotation - else if self_call then - Don't_try_it S.Not_specialised.Self_call else if remaining_inlining_threshold = T.Never_inline then let threshold = match inlining_threshold with @@ -528,9 +528,10 @@ let for_call_site ~env ~r ~(function_decls : Flambda.function_declarations) in if function_decl.stub then let body, r = - Inlining_transforms.inline_by_copying_function_body ~env ~r - ~function_decls ~lhs_of_application ~closure_id_being_applied - ~inline_requested ~specialise_requested ~function_decl ~args ~simplify + Inlining_transforms.inline_by_copying_function_body ~env + ~r ~function_decls ~lhs_of_application + ~closure_id_being_applied ~specialise_requested ~inline_requested + ~function_decl ~args ~dbg ~simplify in simplify env r body else if E.never_inline env then @@ -542,7 +543,7 @@ let for_call_site ~env ~r ~(function_decls : Flambda.function_declarations) let env = E.unset_never_inline_inside_closures env in let env = E.note_entering_call env - ~closure_id:closure_id_being_applied ~debuginfo:dbg + ~closure_id:closure_id_being_applied ~dbg:dbg in let max_level = Clflags.Int_arg_helper.get ~key:(E.round env) !Clflags.inline_max_depth @@ -629,7 +630,7 @@ let for_call_site ~env ~r ~(function_decls : Flambda.function_declarations) ~closure_id_being_applied ~function_decl ~value_set_of_closures ~only_use_of_function ~original ~recursive ~inline_requested ~specialise_requested ~args - ~size_from_approximation ~simplify ~fun_cost ~self_call + ~size_from_approximation ~dbg ~simplify ~fun_cost ~self_call ~inlining_threshold in match inline_result with diff --git a/middle_end/inlining_stats.ml b/middle_end/inlining_stats.ml index d0d18fc8..0c7cc033 100644 --- a/middle_end/inlining_stats.ml +++ b/middle_end/inlining_stats.ml @@ -27,23 +27,23 @@ module Closure_stack = struct let create () = [] - let note_entering_closure t ~closure_id ~debuginfo = + let note_entering_closure t ~closure_id ~dbg = if not !Clflags.inlining_report then t else match t with | [] | (Closure _ | Inlined | Specialised _) :: _-> - (Closure (closure_id, debuginfo)) :: t + (Closure (closure_id, dbg)) :: t | (Call _) :: _ -> Misc.fatal_errorf "note_entering_closure: unexpected Call node" (* CR-someday lwhite: since calls do not have a unique id it is possible some calls will end up sharing nodes. *) - let note_entering_call t ~closure_id ~debuginfo = + let note_entering_call t ~closure_id ~dbg = if not !Clflags.inlining_report then t else match t with | [] | (Closure _ | Inlined | Specialised _) :: _ -> - (Call (closure_id, debuginfo)) :: t + (Call (closure_id, dbg)) :: t | (Call _) :: _ -> Misc.fatal_errorf "note_entering_call: unexpected Call node" @@ -91,13 +91,7 @@ module Inlining_report = struct type t = Debuginfo.t * Closure_id.t * kind let compare ((d1, cl1, k1) : t) ((d2, cl2, k2) : t) = - let c = compare d1.dinfo_file d2.dinfo_file in - if c <> 0 then c else - let c = compare d1.dinfo_line d2.dinfo_line in - if c <> 0 then c else - let c = compare d1.dinfo_char_end d2.dinfo_char_end in - if c <> 0 then c else - let c = compare d1.dinfo_char_start d2.dinfo_char_start in + let c = Debuginfo.compare d1 d2 in if c <> 0 then c else let c = Closure_id.compare cl1 cl2 in if c <> 0 then c else diff --git a/middle_end/inlining_stats.mli b/middle_end/inlining_stats.mli index b0716a2a..f1e84fdc 100644 --- a/middle_end/inlining_stats.mli +++ b/middle_end/inlining_stats.mli @@ -24,13 +24,13 @@ module Closure_stack : sig val note_entering_closure : t -> closure_id:Closure_id.t - -> debuginfo:Debuginfo.t + -> dbg:Debuginfo.t -> t val note_entering_call : t -> closure_id:Closure_id.t - -> debuginfo:Debuginfo.t + -> dbg:Debuginfo.t -> t val note_entering_inlined : t -> t diff --git a/middle_end/inlining_transforms.ml b/middle_end/inlining_transforms.ml old mode 100644 new mode 100755 index 58c24421..d2bcd624 --- a/middle_end/inlining_transforms.ml +++ b/middle_end/inlining_transforms.ml @@ -16,7 +16,6 @@ [@@@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 module R = Inline_and_simplify_aux.Result @@ -116,7 +115,7 @@ let inline_by_copying_function_body ~env ~r ~(inline_requested : Lambda.inline_attribute) ~(specialise_requested : Lambda.specialise_attribute) ~closure_id_being_applied - ~(function_decl : Flambda.function_declaration) ~args ~simplify = + ~(function_decl : Flambda.function_declaration) ~args ~dbg ~simplify = assert (E.mem env lhs_of_application); assert (List.for_all (E.mem env) args); let r = @@ -175,6 +174,7 @@ let inline_by_copying_function_body ~env ~r bindings_for_vars_bound_by_closure_and_params_to_args in let env = E.activate_freshening (E.set_never_inline env) in + let env = E.set_inline_debuginfo ~dbg env in simplify env r expr let inline_by_copying_function_declaration ~env ~r @@ -187,6 +187,19 @@ let inline_by_copying_function_declaration ~env ~r ~(invariant_params:Variable.Set.t Variable.Map.t lazy_t) ~(specialised_args : Flambda.specialised_to Variable.Map.t) ~direct_call_surrogates ~dbg ~simplify = + let function_decls = + (* To simplify a substitution (see comment below), rewrite any references + to closures in the set being defined that go via symbols, so they go + via closure variables instead. *) + let make_closure_symbol = + let module Backend = (val (E.backend env) : Backend_intf.S) in + Backend.closure_symbol + in + Freshening.rewrite_recursive_calls_with_symbols + (Freshening.activate Freshening.empty) + ~make_closure_symbol + function_decls + in let original_function_decls = function_decls in let specialised_args_set = Variable.Map.keys specialised_args in let worth_specialising_args, specialisable_args, args, args_decl = @@ -197,7 +210,7 @@ let inline_by_copying_function_declaration ~env ~r in (* Arguments of functions that are not directly called but are aliased to arguments of a directly called one may need to be - marked as specialiased. *) + marked as specialised. *) let specialisable_args_with_aliases = Variable.Map.fold (fun arg outside_var map -> match Variable.Map.find arg (Lazy.force invariant_params) with @@ -275,6 +288,32 @@ let inline_by_copying_function_declaration ~env ~r Variable.Set.mem func required_functions) function_decls.funs in + let free_vars, free_vars_for_lets, original_vars = + (* Bind all the closures from the original (non-specialised) set as + free variables in the set. This means that we can reference them + when some particular recursive call cannot be specialised. See + detailed comment below. *) + Variable.Map.fold (fun fun_var _fun_decl + (free_vars, free_vars_for_lets, original_vars) -> + let var = Variable.create "closure" in + let original_closure : Flambda.named = + Move_within_set_of_closures + { closure = lhs_of_application; + start_from = closure_id_being_applied; + move_to = Closure_id.wrap fun_var; + } + in + let internal_var = Variable.rename ~append:"_original" fun_var in + let free_vars = + Variable.Map.add internal_var { Flambda. var; projection = None } + free_vars + in + free_vars, + (var, original_closure) :: free_vars_for_lets, + Variable.Map.add fun_var internal_var original_vars) + funs + (free_vars, free_vars_for_lets, Variable.Map.empty) + in let direct_call_surrogates = Closure_id.Map.fold (fun existing surrogate surrogates -> let existing = Closure_id.unwrap existing in @@ -339,6 +378,119 @@ let inline_by_copying_function_declaration ~env ~r None) specialisable_args_with_aliases specialised_args in + let functions'_specialised_params = + Flambda_utils.parameters_specialised_to_the_same_variable + ~function_decls + ~specialised_args:specialisable_args + in + let rewrite_function (fun_decl:Flambda.function_declaration) = + (* First rewrite every use of the closure(s) defined by the current set + of closures to free variable(s) corresponding to the original + (non-specialised) closure(s). + + Then for each call to such closures, if the arguments to the call are + obviously the same as the arguments to which we are specialising the + function, redirect the call to the specialised function. + + In a function like [List.map]: + {[ + let rec specialised_map f l = + match l with + | [] -> [] + | h :: t -> f h :: specialised_map f t + ]} ( with [f] a specialised argument ) + + The first step turns it into: + {[ + let map_original = map in + let rec specialised_map f l = + match l with + | [] -> [] + | h :: t -> f h :: map_original f t + ]} + and the second recognizes the call to [map_original] as a call + preserving the specialised arguments (here [f]). So it is + replaced by [specialised_map f t]. + + In the case of [map] this is a circuituous means of achieving the + desired result, but in general, this provides a way of handling + situations where some recursive calls (for example in subfunctions) + are made with arguments different from the specialised arguments. + The two-pass approach is convenient since the first pass performs + a correct code transformation without optimisation; and then the + second just performs the optimisation on a best-effort basis. + *) + let body_substituted = + (* The use of [Freshening.rewrite_recursive_calls_with_symbols] above + ensures that we catch all calls to the functions being defined + in the current set of closures. *) + Flambda_utils.toplevel_substitution original_vars fun_decl.body + in + let body = + Flambda_iterators.map_toplevel_expr (fun (expr : Flambda.t) -> + match expr with + | Apply apply -> + begin match apply.kind with + | Indirect -> expr + | Direct closure_id -> + (* We recognize the potential recursive calls using the + closure ID rather than [apply.func] because the latter can be + aliases to the function (through a symbol for instance; the + fact that we've now rewritten such symbols to variables + doesn't squash any aliases) rather than being the closure var + directly. *) + let closure_var = Closure_id.unwrap closure_id in + begin match + Variable.Map.find closure_var functions'_specialised_params + with + | exception Not_found -> expr + | specialised_params -> + (* This is a call to one of the functions from the set being + specialised. *) + let apply_is_preserving_specialised_args = + List.length apply.args = List.length specialised_params + && List.for_all2 (fun arg param -> + match + (arg : Flambda_utils.specialised_to_same_as) + with + | Not_specialised -> true + | Specialised_and_aliased_to args -> + (* This is using one of the aliases of [param]. This + is not necessarily the exact same variable as + the original parameter---in particular when the + set contains multiply-recursive functions. *) + Variable.Set.mem param args) + specialised_params + apply.args + in + if apply_is_preserving_specialised_args then + Flambda.Apply + { apply with + func = closure_var; + kind = Direct closure_id; + } + else + expr + end + end + | _ -> expr) + body_substituted + in + Flambda.create_function_declaration + ~params:fun_decl.params + ~stub:fun_decl.stub + ~dbg:fun_decl.dbg + ~inline:fun_decl.inline + ~specialise:fun_decl.specialise + ~is_a_functor:fun_decl.is_a_functor + ~body + in + let funs = + Variable.Map.map rewrite_function function_decls.funs + in + let function_decls = + Flambda.update_function_declarations ~funs function_decls + in let set_of_closures = (* This is the new set of closures, with more precise specialisation information than the one being copied. *) diff --git a/middle_end/inlining_transforms.mli b/middle_end/inlining_transforms.mli index 3995a975..b86716ac 100644 --- a/middle_end/inlining_transforms.mli +++ b/middle_end/inlining_transforms.mli @@ -74,6 +74,7 @@ val inline_by_copying_function_body -> closure_id_being_applied:Closure_id.t -> function_decl:Flambda.function_declaration -> args:Variable.t list + -> dbg:Debuginfo.t -> simplify:Inlining_decision_intf.simplify -> Flambda.t * Inline_and_simplify_aux.Result.t diff --git a/middle_end/invariant_params.ml b/middle_end/invariant_params.ml old mode 100644 new mode 100755 index 76e4b3e6..50114176 --- a/middle_end/invariant_params.ml +++ b/middle_end/invariant_params.ml @@ -278,7 +278,7 @@ let analyse_functions ~backend ~param_to_param let rec f x = ... and g y = f x - We record [(f, x) <- Top] when some unknown values can flow to a the + We record [(f, x) <- Top] when some unknown values can flow to the [y] parameter. let rec f x = f 1 diff --git a/middle_end/lift_code.ml b/middle_end/lift_code.ml index 4098c23a..070bde9e 100644 --- a/middle_end/lift_code.ml +++ b/middle_end/lift_code.ml @@ -16,9 +16,6 @@ [@@@ocaml.warning "+a-4-9-30-40-41-42"] -module A = Simple_value_approx -module C = Inlining_cost - type lifter = Flambda.program -> Flambda.program let rebuild_let diff --git a/middle_end/lift_constants.ml b/middle_end/lift_constants.ml index d9b26d41..6d137e19 100644 --- a/middle_end/lift_constants.ml +++ b/middle_end/lift_constants.ml @@ -20,7 +20,7 @@ let rec tail_variable : Flambda.t -> Variable.t option = function | Var v -> Some v | Let_rec (_, e) - | Let_mutable (_, _, e) + | Let_mutable { body = e } | Let { body = e; _ } -> tail_variable e | _ -> None @@ -63,7 +63,7 @@ let assign_symbols_and_collect_constant_definitions (* [Inconstant_idents] always marks these expressions as inconstant, so we should never get here. *) assert false - | Prim (Pmakeblock (tag, _), fields, _) -> + | Prim (Pmakeblock (tag, _, _value_kind), fields, _) -> assign_symbol (); record_definition (AA.Block (Tag.create_exn tag, fields)) | Read_symbol_field (symbol, field) -> @@ -302,26 +302,30 @@ let translate_definition_and_resolve_alias inconstants [Array (Pfloatarray, _, _)] (which references its contents via variables; it does not contain manifest floats). *) + let find_float_var_definition var = + match Variable.Tbl.find var_to_definition_tbl var with + | Allocated_const (Normal (Float f)) -> f + | const_defining_value -> + Misc.fatal_errorf "Bad definition for float array member %a: %a" + Variable.print var + Alias_analysis.print_constant_defining_value + const_defining_value + in + let find_float_symbol_definition sym = + match Symbol.Map.find sym symbol_definition_map with + | Allocated_const (Float f) -> f + | const_defining_value -> + Misc.fatal_errorf "Bad definition for float array member %a: %a" + Symbol.print sym + Flambda.print_constant_defining_value + const_defining_value + in let floats = List.map (fun var -> - 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) + match Variable.Map.find var aliases with + | exception Not_found -> find_float_var_definition var + | Variable var -> find_float_var_definition var + | Symbol sym -> find_float_symbol_definition sym) vars in let const : Allocated_const.t = @@ -379,14 +383,9 @@ let translate_definition_and_resolve_alias inconstants Duplicate Pfloatarray %a with unknown symbol: %a" Variable.print var Alias_analysis.print_constant_defining_value definition - | Value_float_array { contents = Contents float_array } -> + | Value_float_array value_float_array -> let contents = - Array.fold_right (fun elt acc -> - match acc, elt with - | None, _ | _, None -> None - | Some acc, Some f -> - Some (f :: acc)) - float_array (Some []) + Simple_value_approx.float_array_as_constant value_float_array in begin match contents with | None -> diff --git a/middle_end/lift_let_to_initialize_symbol.ml b/middle_end/lift_let_to_initialize_symbol.ml index 337d0193..d573f546 100644 --- a/middle_end/lift_let_to_initialize_symbol.ml +++ b/middle_end/lift_let_to_initialize_symbol.ml @@ -80,7 +80,7 @@ let rec accumulate ~substitution ~copied_lets ~extracted_lets let extracted = let renamed = Variable.rename var in match named with - | Prim (Pmakeblock (tag, Asttypes.Immutable), args, _dbg) -> + | Prim (Pmakeblock (tag, Asttypes.Immutable, _value_kind), args, _dbg) -> let tag = Tag.create_exn tag in let args = List.map (fun v -> @@ -125,7 +125,7 @@ let rec accumulate ~substitution ~copied_lets ~extracted_lets Flambda_utils.toplevel_substitution def_substitution (Let_rec (renamed_defs, Flambda_utils.name_expr ~name:"lifted_let_rec_block" - (Prim (Pmakeblock (0, Immutable), + (Prim (Pmakeblock (0, Immutable, None), List.map fst renamed_defs, Debuginfo.none)))) in diff --git a/middle_end/projection.ml b/middle_end/projection.ml index deb86488..8183727d 100644 --- a/middle_end/projection.ml +++ b/middle_end/projection.ml @@ -116,7 +116,7 @@ include Identifiable.Make (struct | Project_closure _, _ -> -1 | _, Project_closure _ -> 1 | Move_within_set_of_closures _, _ -> -1 - | _, Move_within_set_of_closures _ -> -1 + | _, Move_within_set_of_closures _ -> 1 let equal t1 t2 = (compare t1 t2) = 0 diff --git a/middle_end/ref_to_variables.ml b/middle_end/ref_to_variables.ml index 0b79b1ca..a59563e2 100644 --- a/middle_end/ref_to_variables.ml +++ b/middle_end/ref_to_variables.ml @@ -54,7 +54,7 @@ let variables_not_used_as_local_reference (tree:Flambda.t) = loop body | Var v -> set := Variable.Set.add v !set - | Let_mutable (_, v, body) -> + | Let_mutable { initial_value = v; body } -> set := Variable.Set.add v !set; loop body | If_then_else (cond, ifso, ifnot) -> @@ -96,7 +96,7 @@ let variables_containing_ref (flam:Flambda.t) = let aux (flam : Flambda.t) = match flam with | Let { var; - defining_expr = Prim(Pmakeblock(0, Asttypes.Mutable), l, _); + defining_expr = Prim(Pmakeblock(0, Asttypes.Mutable, _), l, _); } -> map := Variable.Map.add var (List.length l) !map | _ -> () @@ -132,17 +132,24 @@ let eliminate_ref_of_expr flam = let aux (flam : Flambda.t) : Flambda.t = match flam with | Let { var; - defining_expr = Prim(Pmakeblock(0, Asttypes.Mutable), l, _); + defining_expr = Prim(Pmakeblock(0, Asttypes.Mutable, shape), l,_); body } when convertible_variable var -> + let shape = match shape with + | None -> List.map (fun _ -> Lambda.Pgenval) l + | Some shape -> shape + in let _, expr = - List.fold_left (fun (field,body) init -> + List.fold_left2 (fun (field,body) init kind -> match get_variable var field with | None -> assert false | Some (field_var, _) -> field+1, - ((Let_mutable (field_var, init, body)) : Flambda.t)) - (0,body) l in + (Let_mutable { var = field_var; + initial_value = init; + body; + contents_kind = kind } : Flambda.t)) + (0,body) l shape in expr | Let _ | Let_mutable _ | Assign _ | Var _ | Apply _ diff --git a/middle_end/remove_free_vars_equal_to_args.ml b/middle_end/remove_free_vars_equal_to_args.ml old mode 100644 new mode 100755 index d5df14bd..6b3b59d6 --- a/middle_end/remove_free_vars_equal_to_args.ml +++ b/middle_end/remove_free_vars_equal_to_args.ml @@ -34,7 +34,7 @@ let rewrite_one_function_decl ~(function_decl : Flambda.function_declaration) (* No free variables equal to the param *) subst | set -> - (* Replace the free variables equal to an parameter *) + (* Replace the free variables equal to a parameter *) Variable.Set.fold (fun free_var subst -> Variable.Map.add free_var param subst) set subst) diff --git a/middle_end/remove_unused_arguments.ml b/middle_end/remove_unused_arguments.ml index cfac16e3..42f1c0ff 100644 --- a/middle_end/remove_unused_arguments.ml +++ b/middle_end/remove_unused_arguments.ml @@ -78,13 +78,12 @@ let make_stub unused var (fun_decl : Flambda.function_declaration) in let args = List.map (fun (_, var) -> var) used_args' in let kind = Flambda.Direct (Closure_id.wrap renamed) in - let dbg = fun_decl.dbg in let body : Flambda.t = Apply { func = renamed; args; kind; - dbg; + dbg = fun_decl.dbg; inline = Default_inline; specialise = Default_specialise; } diff --git a/middle_end/semantics_of_primitives.ml b/middle_end/semantics_of_primitives.ml index b8b8c51d..3cedc03f 100644 --- a/middle_end/semantics_of_primitives.ml +++ b/middle_end/semantics_of_primitives.ml @@ -21,7 +21,8 @@ type coeffects = No_coeffects | Has_coeffects let for_primitive (prim : Lambda.primitive) = match prim with - | Pignore | Pidentity -> No_effects, No_coeffects + | Pignore | Pidentity | Pbytes_to_string | Pbytes_of_string -> + No_effects, No_coeffects | Pmakeblock _ | Pmakearray (_, Mutable) -> Only_generative_effects, No_coeffects | Pmakearray (_, Immutable) -> No_effects, No_coeffects @@ -49,9 +50,16 @@ let for_primitive (prim : Lambda.primitive) = | Plsrint | Pasrint | Pintcomp _ -> No_effects, No_coeffects - | Pdivint - | Pmodint -> + | Pdivbint { is_safe = Unsafe } + | Pmodbint { is_safe = Unsafe } + | Pdivint Unsafe + | Pmodint Unsafe -> No_effects, No_coeffects (* Will not raise [Division_by_zero]. *) + | Pdivbint { is_safe = Safe } + | Pmodbint { is_safe = Safe } + | Pdivint Safe + | Pmodint Safe -> + Arbitrary_effects, No_coeffects | Poffsetint _ -> No_effects, No_coeffects | Poffsetref _ -> Arbitrary_effects, Has_coeffects | Pintoffloat @@ -63,7 +71,7 @@ let for_primitive (prim : Lambda.primitive) = | Pmulfloat | Pdivfloat | Pfloatcomp _ -> No_effects, No_coeffects - | Pstringlength + | Pstringlength | Pbyteslength | Parraylength _ -> No_effects, Has_coeffects (* That old chestnut: [Obj.truncate]. *) | Pisint @@ -76,8 +84,6 @@ let for_primitive (prim : Lambda.primitive) = | Paddbint _ | Psubbint _ | Pmulbint _ - | Pdivbint _ - | Pmodbint _ | Pandbint _ | Porbint _ | Pxorbint _ @@ -92,6 +98,7 @@ let for_primitive (prim : Lambda.primitive) = | Pgetglobal _ | Parrayrefu _ | Pstringrefu + | Pbytesrefu | Pstring_load_16 true | Pstring_load_32 true | Pstring_load_64 true @@ -102,6 +109,7 @@ let for_primitive (prim : Lambda.primitive) = No_effects, Has_coeffects | Parrayrefs _ | Pstringrefs + | Pbytesrefs | Pstring_load_16 false | Pstring_load_32 false | Pstring_load_64 false @@ -116,8 +124,8 @@ let for_primitive (prim : Lambda.primitive) = | Psetglobal _ | Parraysetu _ | Parraysets _ - | Pstringsetu - | Pstringsets + | Pbytessetu + | Pbytessets | Pstring_set_16 _ | Pstring_set_32 _ | Pstring_set_64 _ @@ -135,10 +143,30 @@ let for_primitive (prim : Lambda.primitive) = | Popaque -> Arbitrary_effects, Has_coeffects | Ploc _ -> Misc.fatal_error "[Ploc] should have been eliminated by [Translcore]" - | Prevapply _ - | Pdirapply _ + | Prevapply + | Pdirapply | Psequand | Psequor -> Misc.fatal_errorf "The primitive %a should have been eliminated by the \ [Closure_conversion] pass." Printlambda.primitive prim + +type return_type = + | Float + | Other + +let return_type_of_primitive (prim:Lambda.primitive) = + match prim with + | Pfloatofint + | Pnegfloat + | Pabsfloat + | Paddfloat + | Psubfloat + | Pmulfloat + | Pdivfloat + | Pfloatfield _ + | Parrayrefu Pfloatarray + | Parrayrefs Pfloatarray -> + Float + | _ -> + Other diff --git a/middle_end/semantics_of_primitives.mli b/middle_end/semantics_of_primitives.mli index 65231733..32205cee 100644 --- a/middle_end/semantics_of_primitives.mli +++ b/middle_end/semantics_of_primitives.mli @@ -63,3 +63,9 @@ type coeffects = No_coeffects | Has_coeffects val for_primitive : Lambda.primitive -> effects * coeffects + +type return_type = + | Float + | Other + +val return_type_of_primitive : Lambda.primitive -> return_type diff --git a/middle_end/simple_value_approx.ml b/middle_end/simple_value_approx.ml index 50de3181..4d928466 100644 --- a/middle_end/simple_value_approx.ml +++ b/middle_end/simple_value_approx.ml @@ -29,15 +29,6 @@ type value_string = { size : int; } -type value_float_array_contents = - | Contents of float option array - | Unknown_or_mutable - -type value_float_array = { - contents : value_float_array_contents; - size : int; -} - type unknown_because_of = | Unresolved_symbol of Symbol.t | Other @@ -53,7 +44,7 @@ and descr = | Value_int of int | Value_char of char | Value_constptr of int - | Value_float of float + | Value_float of float option | Value_boxed_int : 'a boxed_int * 'a -> descr | Value_set_of_closures of value_set_of_closures | Value_closure of value_closure @@ -80,6 +71,15 @@ and value_set_of_closures = { direct_call_surrogates : Closure_id.t Closure_id.Map.t; } +and value_float_array_contents = + | Contents of t array + | Unknown_or_mutable + +and value_float_array = { + contents : value_float_array_contents; + size : int; +} + let descr t = t.descr let print_value_set_of_closures ppf @@ -113,7 +113,8 @@ let rec print_descr ppf = function print_value_set_of_closures ppf set_of_closures | Value_unresolved sym -> Format.fprintf ppf "(unresolved %a)" Symbol.print sym - | Value_float f -> Format.pp_print_float ppf f + | Value_float (Some f) -> Format.pp_print_float ppf f + | Value_float None -> Format.pp_print_string ppf "float" | Value_string { contents; size } -> begin match contents with | None -> @@ -161,11 +162,48 @@ let augment_with_symbol_field t symbol field = | Some _ -> t let replace_description t descr = { t with descr } +let augment_with_kind t (kind:Lambda.value_kind) = + match kind with + | Pgenval -> t + | Pfloatval -> + begin match t.descr with + | Value_float _ -> + t + | Value_unknown _ | Value_unresolved _ -> + { t with descr = Value_float None } + | Value_block _ + | Value_int _ + | Value_char _ + | Value_constptr _ + | Value_boxed_int _ + | Value_set_of_closures _ + | Value_closure _ + | Value_string _ + | Value_float_array _ + | Value_bottom -> + (* Unreachable *) + { t with descr = Value_bottom } + | Value_extern _ | Value_symbol _ -> + (* We don't know yet *) + t + end + | _ -> t + +let augment_kind_with_approx t (kind:Lambda.value_kind) : Lambda.value_kind = + match t.descr with + | Value_float _ -> Pfloatval + | Value_int _ -> Pintval + | Value_boxed_int (Int32, _) -> Pboxedintval Pint32 + | Value_boxed_int (Int64, _) -> Pboxedintval Pint64 + | Value_boxed_int (Nativeint, _) -> Pboxedintval Pnativeint + | _ -> kind + let value_unknown reason = approx (Value_unknown reason) let value_int i = approx (Value_int i) let value_char i = approx (Value_char i) let value_constptr i = approx (Value_constptr i) -let value_float f = approx (Value_float f) +let value_float f = approx (Value_float (Some f)) +let value_any_float = approx (Value_float None) let value_boxed_int bi i = approx (Value_boxed_int (bi,i)) let value_closure ?closure_var ?set_of_closures_var ?set_of_closures_symbol @@ -239,8 +277,11 @@ let value_unresolved sym = approx (Value_unresolved sym) let value_string size contents = approx (Value_string {size; contents }) let value_mutable_float_array ~size = approx (Value_float_array { contents = Unknown_or_mutable; size; } ) -let value_immutable_float_array contents = +let value_immutable_float_array (contents:t array) = let size = Array.length contents in + let contents = + Array.map (fun t -> augment_with_kind t Pfloatval) contents + in approx (Value_float_array { contents = Contents contents; size; } ) let name_expr_fst (named, thing) ~name = @@ -314,7 +355,7 @@ let simplify t (lam : Flambda.t) : simplification_result = | Value_constptr n -> let const, approx = make_const_ptr n in const, Replaced_term, approx - | Value_float f -> + | Value_float (Some f) -> let const, approx = make_const_float f in const, Replaced_term, approx | Value_boxed_int (t, i) -> @@ -322,7 +363,7 @@ let simplify t (lam : Flambda.t) : simplification_result = const, Replaced_term, approx | Value_symbol sym -> U.name_expr (Symbol sym) ~name:"symbol", Replaced_term, t - | Value_string _ | Value_float_array _ + | Value_string _ | Value_float_array _ | Value_float None | Value_block _ | Value_set_of_closures _ | Value_closure _ | Value_unknown _ | Value_bottom | Value_extern _ | Value_unresolved _ -> lam, Nothing_done, t @@ -341,7 +382,7 @@ let simplify_named t (named : Flambda.named) : simplification_result_named = | Value_constptr n -> let const, approx = make_const_ptr_named n in const, Replaced_term, approx - | Value_float f -> + | Value_float (Some f) -> let const, approx = make_const_float_named f in const, Replaced_term, approx | Value_boxed_int (t, i) -> @@ -349,7 +390,7 @@ let simplify_named t (named : Flambda.named) : simplification_result_named = const, Replaced_term, approx | Value_symbol sym -> Symbol sym, Replaced_term, t - | Value_string _ | Value_float_array _ + | Value_string _ | Value_float_array _ | Value_float None | Value_block _ | Value_set_of_closures _ | Value_closure _ | Value_unknown _ | Value_bottom | Value_extern _ | Value_unresolved _ -> named, Nothing_done, t @@ -363,10 +404,10 @@ let simplify_var t : (Flambda.named * t) option = | Value_int n -> Some (make_const_int_named n) | Value_char n -> Some (make_const_char_named n) | Value_constptr n -> Some (make_const_ptr_named n) - | Value_float f -> Some (make_const_float_named f) + | Value_float (Some f) -> Some (make_const_float_named f) | Value_boxed_int (t, i) -> Some (make_const_boxed_int_named t i) | Value_symbol sym -> Some (Symbol sym, t) - | Value_string _ | Value_float_array _ + | Value_string _ | Value_float_array _ | Value_float None | Value_block _ | Value_set_of_closures _ | Value_closure _ | Value_unknown _ | Value_bottom | Value_extern _ | Value_unresolved _ -> @@ -541,7 +582,7 @@ let equal_boxed_int (type t1) (type t2) rewriting [Project_var] and [Project_closure] constructions in [Flambdainline.loop] *) -let rec meet_descr d1 d2 = match d1, d2 with +let rec meet_descr ~really_import_approx d1 d2 = match d1, d2 with | Value_int i, Value_int j when i = j -> d1 | Value_constptr i, Value_constptr j when i = j -> @@ -557,13 +598,20 @@ let rec meet_descr d1 d2 = match d1, d2 with d1 | Value_block (tag1, a1), Value_block (tag2, a2) when tag1 = tag2 && Array.length a1 = Array.length a2 -> - Value_block (tag1, Array.mapi (fun i v -> meet v a2.(i)) a1) + let fields = + Array.mapi (fun i v -> meet ~really_import_approx v a2.(i)) a1 + in + Value_block (tag1, fields) | _ -> Value_unknown Other -and meet a1 a2 = +and meet ~really_import_approx a1 a2 = match a1, a2 with | { descr = Value_bottom }, a | a, { descr = Value_bottom } -> a + | { descr = (Value_symbol _ | Value_extern _) }, _ + | _, { descr = (Value_symbol _ | Value_extern _) } -> + meet ~really_import_approx + (really_import_approx a1) (really_import_approx a2) | _ -> let var = match a1.var, a2.var with @@ -585,7 +633,7 @@ and meet a1 a2 = | _ -> None else None in - { descr = meet_descr a1.descr a2.descr; + { descr = meet_descr ~really_import_approx a1.descr a2.descr; var; symbol } @@ -710,10 +758,92 @@ let approx_for_bound_var value_set_of_closures var = let check_approx_for_float t : float option = match t.descr with - | Value_float f -> Some f + | Value_float f -> f | Value_unresolved _ | Value_unknown _ | Value_string _ | Value_float_array _ | Value_bottom | Value_block _ | Value_int _ | Value_char _ | Value_constptr _ | Value_set_of_closures _ | Value_closure _ | Value_extern _ | Value_boxed_int _ | Value_symbol _ -> None + +let float_array_as_constant (t:value_float_array) : float list option = + match t.contents with + | Unknown_or_mutable -> None + | Contents contents -> + Array.fold_right (fun elt acc -> + match acc, elt.descr with + | Some acc, Value_float (Some f) -> + Some (f :: acc) + | None, _ + | Some _, + (Value_float None | Value_unresolved _ + | Value_unknown _ | Value_string _ | Value_float_array _ + | Value_bottom | Value_block _ | Value_int _ | Value_char _ + | Value_constptr _ | Value_set_of_closures _ | Value_closure _ + | Value_extern _ | Value_boxed_int _ | Value_symbol _) + -> None) + contents (Some []) + +let check_approx_for_string t : string option = + match t.descr with + | Value_string { contents } -> contents + | Value_float _ + | Value_unresolved _ + | Value_unknown _ | Value_float_array _ + | Value_bottom | Value_block _ | Value_int _ | Value_char _ + | Value_constptr _ | Value_set_of_closures _ | Value_closure _ + | Value_extern _ | Value_boxed_int _ | Value_symbol _ -> + None + +type switch_branch_selection = + | Cannot_be_taken + | Can_be_taken + | Must_be_taken + +let potentially_taken_const_switch_branch t branch = + match t.descr with + | Value_unresolved _ + | Value_unknown _ + | Value_extern _ + | Value_symbol _ -> + (* In theory symbol cannot contain integers but this shouldn't + matter as this will always be an imported approximation *) + Can_be_taken + | Value_constptr i | Value_int i when i = branch -> + Must_be_taken + | Value_char c when Char.code c = branch -> + Must_be_taken + | Value_constptr _ | Value_int _ | Value_char _ -> + Cannot_be_taken + | Value_block _ | Value_float _ | Value_float_array _ + | Value_string _ | Value_closure _ | Value_set_of_closures _ + | Value_boxed_int _ | Value_bottom -> + Cannot_be_taken + +let potentially_taken_block_switch_branch t tag = + match t.descr with + | (Value_unresolved _ + | Value_unknown _ + | Value_extern _ + | Value_symbol _) -> + Can_be_taken + | (Value_constptr _ | Value_int _| Value_char _) -> + Cannot_be_taken + | Value_block (block_tag, _) when Tag.to_int block_tag = tag -> + Must_be_taken + | Value_float _ when tag = Obj.double_tag -> + Must_be_taken + | Value_float_array _ when tag = Obj.double_array_tag -> + Must_be_taken + | Value_string _ when tag = Obj.string_tag -> + Must_be_taken + | (Value_closure _ | Value_set_of_closures _) + when tag = Obj.closure_tag || tag = Obj.infix_tag -> + Can_be_taken + | Value_boxed_int _ when tag = Obj.custom_tag -> + Must_be_taken + | Value_block _ | Value_float _ | Value_set_of_closures _ | Value_closure _ + | Value_string _ | Value_float_array _ | Value_boxed_int _ -> + Cannot_be_taken + | Value_bottom -> + Cannot_be_taken diff --git a/middle_end/simple_value_approx.mli b/middle_end/simple_value_approx.mli index bc1ce121..36501b05 100644 --- a/middle_end/simple_value_approx.mli +++ b/middle_end/simple_value_approx.mli @@ -30,15 +30,6 @@ type value_string = { size : int; } -type value_float_array_contents = - | Contents of float option array - | Unknown_or_mutable - -type value_float_array = { - contents : value_float_array_contents; - size : int; -} - type unknown_because_of = | Unresolved_symbol of Symbol.t | Other @@ -130,7 +121,7 @@ and descr = private | Value_int of int | Value_char of char | Value_constptr of int - | Value_float of float + | Value_float of float option | Value_boxed_int : 'a boxed_int * 'a -> descr | Value_set_of_closures of value_set_of_closures | Value_closure of value_closure @@ -162,6 +153,15 @@ and value_set_of_closures = private { direct_call_surrogates : Closure_id.t Closure_id.Map.t; } +and value_float_array_contents = + | Contents of t array + | Unknown_or_mutable + +and value_float_array = { + contents : value_float_array_contents; + size : int; +} + (** Extraction of the description of approximation(s). *) val descr : t -> descr val descrs : t list -> descr list @@ -193,8 +193,9 @@ val value_unknown : unknown_because_of -> t val value_int : int -> t val value_char : char -> t val value_float : float -> t +val value_any_float : t val value_mutable_float_array : size:int -> t -val value_immutable_float_array : float option array -> t +val value_immutable_float_array : t array -> t val value_string : int -> string option -> t val value_boxed_int : 'i boxed_int -> 'i -> t val value_constptr : int -> t @@ -255,11 +256,17 @@ val augment_with_symbol_field : t -> Symbol.t -> int -> t (** Replace the description within an approximation. *) val replace_description : t -> descr -> t +(** Improve the description by taking the kind into account *) +val augment_with_kind : t -> Lambda.value_kind -> t + +(** Improve the kind by taking the description into account *) +val augment_kind_with_approx : t -> Lambda.value_kind -> Lambda.value_kind + val equal_boxed_int : 'a boxed_int -> 'a -> 'b boxed_int -> 'b -> bool (* CR-soon mshinwell for pchambart: Add comment describing semantics. (Maybe we should move the comment from the .ml file into here.) *) -val meet : t -> t -> t +val meet : really_import_approx:(t -> t) -> t -> t -> t (** An approximation is "known" iff it is not [Value_unknown]. *) val known : t -> bool @@ -399,3 +406,18 @@ val check_approx_for_closure_allowing_unresolved (** Returns the value if it can be proved to be a constant float *) val check_approx_for_float : t -> float option + +(** Returns the value if it can be proved to be a constant float array *) +val float_array_as_constant : value_float_array -> float list option + +(** Returns the value if it can be proved to be a constant string *) +val check_approx_for_string : t -> string option + +type switch_branch_selection = + | Cannot_be_taken + | Can_be_taken + | Must_be_taken + +(** Check that the branch is compatible with the approximation *) +val potentially_taken_const_switch_branch : t -> int -> switch_branch_selection +val potentially_taken_block_switch_branch : t -> int -> switch_branch_selection diff --git a/middle_end/simplify_boxed_integer_ops.ml b/middle_end/simplify_boxed_integer_ops.ml index 336cc16b..8fdc045d 100644 --- a/middle_end/simplify_boxed_integer_ops.ml +++ b/middle_end/simplify_boxed_integer_ops.ml @@ -67,8 +67,8 @@ end) : Simplify_boxed_integer_ops_intf.S with type t := I.t = struct | Paddbint kind when kind = I.kind -> eval I.add | Psubbint kind when kind = I.kind -> eval I.sub | Pmulbint kind when kind = I.kind -> eval I.mul - | Pdivbint kind when kind = I.kind && non_zero n2 -> eval I.div - | Pmodbint kind when kind = I.kind && non_zero n2 -> eval I.rem + | Pdivbint {size=kind} when kind = I.kind && non_zero n2 -> eval I.div + | Pmodbint {size=kind} when kind = I.kind && non_zero n2 -> eval I.rem | Pandbint kind when kind = I.kind -> eval I.logand | Porbint kind when kind = I.kind -> eval I.logor | Pxorbint kind when kind = I.kind -> eval I.logxor diff --git a/middle_end/simplify_primitives.ml b/middle_end/simplify_primitives.ml index c6ec4ad0..14c43efe 100644 --- a/middle_end/simplify_primitives.ml +++ b/middle_end/simplify_primitives.ml @@ -41,9 +41,16 @@ let primitive (p : Lambda.primitive) (args, approxs) expr dbg ~size_int ~big_endian : Flambda.named * A.t * Inlining_cost.Benefit.t = let fpc = !Clflags.float_const_prop in match p with - | Pmakeblock(tag, Asttypes.Immutable) -> - let tag = Tag.create_exn tag in - expr, A.value_block tag (Array.of_list approxs), C.Benefit.zero + | Pmakeblock(tag_int, Asttypes.Immutable, shape) -> + let tag = Tag.create_exn tag_int in + let shape = match shape with + | None -> List.map (fun _ -> Lambda.Pgenval) args + | Some shape -> shape + in + let approxs = List.map2 A.augment_with_kind approxs shape in + let shape = List.map2 A.augment_kind_with_approx approxs shape in + Prim (Pmakeblock(tag_int, Asttypes.Immutable, Some shape), args, dbg), + A.value_block tag (Array.of_list approxs), C.Benefit.zero | Praise _ -> expr, A.value_bottom, C.Benefit.zero | Pignore -> begin @@ -59,12 +66,13 @@ let primitive (p : Lambda.primitive) (args, approxs) expr dbg ~size_int expr, approx, C.Benefit.zero | Pmakearray (Pfloatarray, Immutable) -> let approx = - A.value_immutable_float_array - (Array.of_list (List.map A.check_approx_for_float approxs)) + A.value_immutable_float_array (Array.of_list approxs) in expr, approx, C.Benefit.zero | Pintcomp Ceq when phys_equal approxs -> S.const_bool_expr expr true + | Pintcomp Cneq when phys_equal approxs -> + S.const_bool_expr expr false (* N.B. Having [not (phys_equal approxs)] would not on its own tell us anything about whether the two values concerned are unequal. To judge that, it would be necessary to prove that the approximations are @@ -108,8 +116,8 @@ let primitive (p : Lambda.primitive) (args, approxs) expr dbg ~size_int | Paddint -> S.const_int_expr expr (x + y) | Psubint -> S.const_int_expr expr (x - y) | Pmulint -> S.const_int_expr expr (x * y) - | Pdivint when y <> 0 -> S.const_int_expr expr (x / y) - | Pmodint when y <> 0 -> S.const_int_expr expr (x mod y) + | Pdivint _ when y <> 0 -> S.const_int_expr expr (x / y) + | Pmodint _ when y <> 0 -> S.const_int_expr expr (x mod y) | Pandint -> S.const_int_expr expr (x land y) | Porint -> S.const_int_expr expr (x lor y) | Pxorint -> S.const_int_expr expr (x lxor y) @@ -118,7 +126,11 @@ let primitive (p : Lambda.primitive) (args, approxs) expr dbg ~size_int | Pasrint when shift_precond -> S.const_int_expr expr (x asr y) | Pintcomp cmp -> S.const_comparison_expr expr cmp x y | Pisout -> S.const_bool_expr expr (y > x || y < 0) - (* [Psequand] and [Psequor] have special simplification rules, above. *) + | _ -> expr, A.value_unknown Other, C.Benefit.zero + end + | [Value_char x; Value_char y] -> + begin match p with + | Pintcomp cmp -> S.const_comparison_expr expr cmp x y | _ -> expr, A.value_unknown Other, C.Benefit.zero end | [Value_constptr x] -> @@ -140,17 +152,19 @@ let primitive (p : Lambda.primitive) (args, approxs) expr dbg ~size_int | Ostype_unix -> S.const_bool_expr expr (Sys.os_type = "Unix") | Ostype_win32 -> S.const_bool_expr expr (Sys.os_type = "Win32") | Ostype_cygwin -> S.const_bool_expr expr (Sys.os_type = "Cygwin") + | Backend_type -> + S.const_ptr_expr expr 0 (* tag 0 is the same as Native *) end | _ -> expr, A.value_unknown Other, C.Benefit.zero end - | [Value_float x] when fpc -> + | [Value_float (Some x)] when fpc -> begin match p with | Pintoffloat -> S.const_int_expr expr (int_of_float x) | Pnegfloat -> S.const_float_expr expr (-. x) | Pabsfloat -> S.const_float_expr expr (abs_float x) | _ -> expr, A.value_unknown Other, C.Benefit.zero end - | [Value_float n1; Value_float n2] when fpc -> + | [Value_float (Some n1); Value_float (Some n2)] when fpc -> begin match p with | Paddfloat -> S.const_float_expr expr (n1 +. n2) | Psubfloat -> S.const_float_expr expr (n1 -. n2) @@ -183,13 +197,17 @@ let primitive (p : Lambda.primitive) (args, approxs) expr dbg ~size_int ~size_int | [Value_block _] when p = Lambda.Pisint -> S.const_bool_expr expr false - | [Value_string { size }] when p = Lambda.Pstringlength -> + | [Value_string { size }] + when (p = Lambda.Pstringlength || p = Lambda.Pbyteslength) -> S.const_int_expr expr size | [Value_string { size; contents = Some s }; (Value_int x | Value_constptr x)] when x >= 0 && x < size -> begin match p with | Pstringrefu - | Pstringrefs -> S.const_char_expr expr s.[x] + | Pstringrefs + | Pbytesrefu + | Pbytesrefs -> + S.const_char_expr (Prim(Pstringrefu, args, dbg)) s.[x] | _ -> expr, A.value_unknown Other, C.Benefit.zero end | [Value_string { size; contents = None }; @@ -199,14 +217,22 @@ let primitive (p : Lambda.primitive) (args, approxs) expr dbg ~size_int A.value_unknown Other, (* we improved it, but there is no way to account for that: *) C.Benefit.zero + | [Value_string { size; contents = None }; + (Value_int x | Value_constptr x)] + when x >= 0 && x < size && p = Lambda.Pbytesrefs -> + Flambda.Prim (Pbytesrefu, args, dbg), + A.value_unknown Other, + (* we improved it, but there is no way to account for that: *) + C.Benefit.zero + | [Value_float_array { size; contents }] -> begin match p with | Parraylength _ -> S.const_int_expr expr size | Pfloatfield i -> begin match contents with | A.Contents a when i >= 0 && i < size -> - begin match a.(i) with - | None -> expr, A.value_unknown Other, C.Benefit.zero + begin match A.check_approx_for_float a.(i) with + | None -> expr, a.(i), C.Benefit.zero | Some v -> S.const_float_expr expr v end | Contents _ | Unknown_or_mutable -> @@ -214,4 +240,9 @@ let primitive (p : Lambda.primitive) (args, approxs) expr dbg ~size_int end | _ -> expr, A.value_unknown Other, C.Benefit.zero end - | _ -> expr, A.value_unknown Other, C.Benefit.zero + | _ -> + match Semantics_of_primitives.return_type_of_primitive p with + | Float -> + expr, A.value_any_float, C.Benefit.zero + | Other -> + expr, A.value_unknown Other, C.Benefit.zero diff --git a/middle_end/unbox_specialised_args.ml b/middle_end/unbox_specialised_args.ml old mode 100644 new mode 100755 index ced1636c..32ce4088 --- a/middle_end/unbox_specialised_args.ml +++ b/middle_end/unbox_specialised_args.ml @@ -63,7 +63,7 @@ module Transform = struct (* If for function [f] we would extract a projection expression [e] from some specialised argument [x] of [f], and we know from [Invariant_params] that a specialised argument [y] of - another function [g] flows to [x], we will add add [e] with + another function [g] flows to [x], we will add [e] with [y] substituted for [x] throughout as a newly-specialised argument for [g]. This should help reduce the number of simplification rounds required for mutually-recursive diff --git a/ocamldoc/.depend b/ocamldoc/.depend index c66b0750..9aaef1f9 100644 --- a/ocamldoc/.depend +++ b/ocamldoc/.depend @@ -1,27 +1,26 @@ -odoc.cmo : ../typing/typedtree.cmi odoc_messages.cmo odoc_info.cmi \ - odoc_global.cmi odoc_gen.cmi odoc_config.cmi odoc_args.cmi \ - odoc_analyse.cmi ../utils/misc.cmi ../utils/config.cmi \ - ../utils/clflags.cmi -odoc.cmx : ../typing/typedtree.cmx odoc_messages.cmx odoc_info.cmx \ - odoc_global.cmx odoc_gen.cmx odoc_config.cmx odoc_args.cmx \ - odoc_analyse.cmx ../utils/misc.cmx ../utils/config.cmx \ - ../utils/clflags.cmx +odoc.cmo : odoc_messages.cmo odoc_info.cmi odoc_global.cmi odoc_gen.cmi \ + odoc_config.cmi odoc_args.cmi odoc_analyse.cmi +odoc.cmx : odoc_messages.cmx odoc_info.cmx odoc_global.cmx odoc_gen.cmx \ + odoc_config.cmx odoc_args.cmx odoc_analyse.cmx odoc_analyse.cmo : ../utils/warnings.cmi ../typing/types.cmi \ ../typing/typemod.cmi ../typing/typedtree.cmi ../parsing/syntaxerr.cmi \ ../driver/pparse.cmi ../parsing/parse.cmi odoc_types.cmi odoc_text.cmi \ odoc_sig.cmi odoc_module.cmo odoc_misc.cmi odoc_messages.cmo \ odoc_merge.cmi odoc_global.cmi odoc_dep.cmo odoc_cross.cmi \ odoc_comments.cmi odoc_class.cmo odoc_ast.cmi ../utils/misc.cmi \ - ../parsing/location.cmi ../parsing/lexer.cmi ../typing/env.cmi \ - ../utils/config.cmi ../utils/clflags.cmi odoc_analyse.cmi + ../parsing/longident.cmi ../parsing/location.cmi ../parsing/lexer.cmi \ + ../typing/env.cmi ../utils/config.cmi ../utils/clflags.cmi \ + ../parsing/asttypes.cmi odoc_analyse.cmi odoc_analyse.cmx : ../utils/warnings.cmx ../typing/types.cmx \ ../typing/typemod.cmx ../typing/typedtree.cmx ../parsing/syntaxerr.cmx \ ../driver/pparse.cmx ../parsing/parse.cmx odoc_types.cmx odoc_text.cmx \ odoc_sig.cmx odoc_module.cmx odoc_misc.cmx odoc_messages.cmx \ odoc_merge.cmx odoc_global.cmx odoc_dep.cmx odoc_cross.cmx \ odoc_comments.cmx odoc_class.cmx odoc_ast.cmx ../utils/misc.cmx \ - ../parsing/location.cmx ../parsing/lexer.cmx ../typing/env.cmx \ - ../utils/config.cmx ../utils/clflags.cmx odoc_analyse.cmi + ../parsing/longident.cmx ../parsing/location.cmx ../parsing/lexer.cmx \ + ../typing/env.cmx ../utils/config.cmx ../utils/clflags.cmx \ + ../parsing/asttypes.cmi odoc_analyse.cmi +odoc_analyse.cmi : odoc_module.cmo odoc_global.cmi odoc_args.cmo : ../utils/warnings.cmi odoc_types.cmi odoc_texi.cmo \ odoc_messages.cmo odoc_man.cmo odoc_latex.cmo odoc_html.cmo \ odoc_global.cmi odoc_gen.cmi odoc_dot.cmo odoc_config.cmi \ @@ -34,20 +33,23 @@ odoc_args.cmx : ../utils/warnings.cmx odoc_types.cmx odoc_texi.cmx \ ../utils/misc.cmx ../driver/main_args.cmx ../parsing/location.cmx \ ../utils/config.cmx ../driver/compenv.cmx ../utils/clflags.cmx \ odoc_args.cmi +odoc_args.cmi : odoc_gen.cmi odoc_ast.cmo : ../typing/types.cmi ../typing/typedtree.cmi \ ../typing/predef.cmi ../typing/path.cmi ../parsing/parsetree.cmi \ odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_sig.cmi \ - odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_messages.cmo \ - odoc_global.cmi odoc_extension.cmo odoc_exception.cmo odoc_env.cmi \ - odoc_class.cmo ../utils/misc.cmi ../parsing/location.cmi \ - ../typing/ident.cmi ../parsing/asttypes.cmi odoc_ast.cmi + odoc_parameter.cmo odoc_module.cmo odoc_messages.cmo odoc_global.cmi \ + odoc_extension.cmo odoc_exception.cmo odoc_env.cmi odoc_class.cmo \ + ../utils/misc.cmi ../parsing/location.cmi ../typing/ident.cmi \ + ../parsing/asttypes.cmi odoc_ast.cmi odoc_ast.cmx : ../typing/types.cmx ../typing/typedtree.cmx \ ../typing/predef.cmx ../typing/path.cmx ../parsing/parsetree.cmi \ odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_sig.cmx \ - odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_messages.cmx \ - odoc_global.cmx odoc_extension.cmx odoc_exception.cmx odoc_env.cmx \ - odoc_class.cmx ../utils/misc.cmx ../parsing/location.cmx \ - ../typing/ident.cmx ../parsing/asttypes.cmi odoc_ast.cmi + odoc_parameter.cmx odoc_module.cmx odoc_messages.cmx odoc_global.cmx \ + odoc_extension.cmx odoc_exception.cmx odoc_env.cmx odoc_class.cmx \ + ../utils/misc.cmx ../parsing/location.cmx ../typing/ident.cmx \ + ../parsing/asttypes.cmi odoc_ast.cmi +odoc_ast.cmi : ../typing/types.cmi ../typing/typedtree.cmi \ + ../parsing/parsetree.cmi odoc_sig.cmi odoc_name.cmi odoc_module.cmo odoc_class.cmo : ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ odoc_parameter.cmo odoc_name.cmi odoc_class.cmx : ../typing/types.cmx odoc_value.cmx odoc_types.cmx \ @@ -60,10 +62,13 @@ odoc_comments.cmx : odoc_types.cmx odoc_text.cmx odoc_see_lexer.cmx \ odoc_parser.cmx odoc_misc.cmx odoc_messages.cmx odoc_merge.cmx \ odoc_lexer.cmx odoc_global.cmx odoc_cross.cmx odoc_comments_global.cmx \ odoc_comments.cmi +odoc_comments.cmi : odoc_types.cmi odoc_module.cmo odoc_comments_global.cmo : odoc_comments_global.cmi odoc_comments_global.cmx : odoc_comments_global.cmi +odoc_comments_global.cmi : odoc_config.cmo : ../utils/config.cmi odoc_config.cmi odoc_config.cmx : ../utils/config.cmx odoc_config.cmi +odoc_config.cmi : odoc_control.cmo : odoc_control.cmx : odoc_cross.cmo : odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_search.cmi \ @@ -74,12 +79,14 @@ odoc_cross.cmx : odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_search.cmx \ odoc_scan.cmx odoc_parameter.cmx odoc_name.cmx odoc_module.cmx \ odoc_misc.cmx odoc_messages.cmx odoc_global.cmx odoc_extension.cmx \ odoc_exception.cmx odoc_class.cmx odoc_cross.cmi +odoc_cross.cmi : odoc_types.cmi odoc_module.cmo odoc_dag2html.cmo : odoc_info.cmi odoc_dag2html.cmi odoc_dag2html.cmx : odoc_info.cmx odoc_dag2html.cmi +odoc_dag2html.cmi : odoc_info.cmi odoc_dep.cmo : ../parsing/parsetree.cmi odoc_type.cmo odoc_print.cmi \ - odoc_module.cmo ../tools/depend.cmi + odoc_module.cmo ../parsing/depend.cmi odoc_dep.cmx : ../parsing/parsetree.cmi odoc_type.cmx odoc_print.cmx \ - odoc_module.cmx ../tools/depend.cmx + odoc_module.cmx ../parsing/depend.cmx odoc_dot.cmo : odoc_messages.cmo odoc_info.cmi odoc_dot.cmx : odoc_messages.cmx odoc_info.cmx odoc_env.cmo : ../typing/types.cmi ../typing/printtyp.cmi \ @@ -88,6 +95,7 @@ odoc_env.cmo : ../typing/types.cmi ../typing/printtyp.cmi \ odoc_env.cmx : ../typing/types.cmx ../typing/printtyp.cmx \ ../typing/predef.cmx ../typing/path.cmx odoc_name.cmx ../utils/misc.cmx \ ../typing/btype.cmx odoc_env.cmi +odoc_env.cmi : ../typing/types.cmi odoc_name.cmi odoc_exception.cmo : ../typing/types.cmi odoc_types.cmi odoc_type.cmo \ odoc_name.cmi odoc_exception.cmx : ../typing/types.cmx odoc_types.cmx odoc_type.cmx \ @@ -100,10 +108,13 @@ odoc_gen.cmo : odoc_texi.cmo odoc_module.cmo odoc_man.cmo odoc_latex.cmo \ odoc_html.cmo odoc_dot.cmo odoc_gen.cmi odoc_gen.cmx : odoc_texi.cmx odoc_module.cmx odoc_man.cmx odoc_latex.cmx \ odoc_html.cmx odoc_dot.cmx odoc_gen.cmi +odoc_gen.cmi : odoc_texi.cmo odoc_module.cmo odoc_man.cmo odoc_latex.cmo \ + odoc_html.cmo odoc_dot.cmo odoc_global.cmo : odoc_types.cmi odoc_messages.cmo odoc_config.cmi \ ../utils/clflags.cmi odoc_global.cmi odoc_global.cmx : odoc_types.cmx odoc_messages.cmx odoc_config.cmx \ ../utils/clflags.cmx odoc_global.cmi +odoc_global.cmi : odoc_types.cmi odoc_html.cmo : odoc_text.cmi odoc_ocamlhtml.cmo odoc_messages.cmo \ odoc_info.cmi odoc_global.cmi odoc_dag2html.cmi ../parsing/asttypes.cmi odoc_html.cmx : odoc_text.cmx odoc_ocamlhtml.cmx odoc_messages.cmx \ @@ -120,6 +131,10 @@ odoc_info.cmx : ../typing/printtyp.cmx odoc_value.cmx odoc_types.cmx \ odoc_misc.cmx odoc_global.cmx odoc_extension.cmx odoc_exception.cmx \ odoc_dep.cmx odoc_config.cmx odoc_comments.cmx odoc_class.cmx \ odoc_analyse.cmx ../parsing/location.cmx odoc_info.cmi +odoc_info.cmi : ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ + odoc_type.cmo odoc_search.cmi odoc_parameter.cmo odoc_module.cmo \ + odoc_global.cmi odoc_extension.cmo odoc_exception.cmo odoc_class.cmo \ + ../parsing/location.cmi ../parsing/asttypes.cmi odoc_inherit.cmo : odoc_inherit.cmx : odoc_latex.cmo : odoc_to_text.cmo odoc_messages.cmo odoc_latex_style.cmo \ @@ -137,13 +152,12 @@ odoc_man.cmo : odoc_str.cmi odoc_print.cmi odoc_misc.cmi odoc_messages.cmo \ odoc_man.cmx : odoc_str.cmx odoc_print.cmx odoc_misc.cmx odoc_messages.cmx \ odoc_info.cmx ../utils/misc.cmx ../parsing/asttypes.cmi odoc_merge.cmo : odoc_value.cmo odoc_types.cmi odoc_type.cmo \ - odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_messages.cmo \ - odoc_global.cmi odoc_extension.cmo odoc_exception.cmo odoc_class.cmo \ - odoc_merge.cmi + odoc_parameter.cmo odoc_module.cmo odoc_messages.cmo odoc_global.cmi \ + odoc_extension.cmo odoc_exception.cmo odoc_class.cmo odoc_merge.cmi odoc_merge.cmx : odoc_value.cmx odoc_types.cmx odoc_type.cmx \ - odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_messages.cmx \ - odoc_global.cmx odoc_extension.cmx odoc_exception.cmx odoc_class.cmx \ - odoc_merge.cmi + odoc_parameter.cmx odoc_module.cmx odoc_messages.cmx odoc_global.cmx \ + odoc_extension.cmx odoc_exception.cmx odoc_class.cmx odoc_merge.cmi +odoc_merge.cmi : odoc_types.cmi odoc_module.cmo odoc_messages.cmo : ../utils/config.cmi odoc_messages.cmx : ../utils/config.cmx odoc_misc.cmo : ../typing/types.cmi ../typing/predef.cmi ../typing/path.cmi \ @@ -152,6 +166,8 @@ odoc_misc.cmo : ../typing/types.cmi ../typing/predef.cmi ../typing/path.cmi \ odoc_misc.cmx : ../typing/types.cmx ../typing/predef.cmx ../typing/path.cmx \ odoc_types.cmx odoc_messages.cmx ../parsing/longident.cmx \ ../typing/ctype.cmx ../typing/btype.cmx odoc_misc.cmi +odoc_misc.cmi : ../typing/types.cmi odoc_types.cmi ../parsing/longident.cmi \ + ../parsing/asttypes.cmi odoc_module.cmo : ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ odoc_type.cmo odoc_name.cmi odoc_extension.cmo odoc_exception.cmo \ odoc_class.cmo @@ -162,44 +178,51 @@ odoc_name.cmo : ../typing/path.cmi odoc_misc.cmi ../typing/ident.cmi \ odoc_name.cmi odoc_name.cmx : ../typing/path.cmx odoc_misc.cmx ../typing/ident.cmx \ odoc_name.cmi +odoc_name.cmi : ../typing/path.cmi ../parsing/longident.cmi \ + ../typing/ident.cmi odoc_ocamlhtml.cmo : odoc_ocamlhtml.cmx : odoc_parameter.cmo : ../typing/types.cmi odoc_types.cmi odoc_parameter.cmx : ../typing/types.cmx odoc_types.cmx odoc_parser.cmo : odoc_types.cmi odoc_comments_global.cmi odoc_parser.cmi odoc_parser.cmx : odoc_types.cmx odoc_comments_global.cmx odoc_parser.cmi +odoc_parser.cmi : odoc_types.cmi odoc_print.cmo : ../typing/types.cmi ../typing/printtyp.cmi \ ../utils/misc.cmi odoc_print.cmi odoc_print.cmx : ../typing/types.cmx ../typing/printtyp.cmx \ ../utils/misc.cmx odoc_print.cmi +odoc_print.cmi : ../typing/types.cmi odoc_scan.cmo : odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_module.cmo \ odoc_extension.cmo odoc_exception.cmo odoc_class.cmo odoc_scan.cmx : odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_module.cmx \ odoc_extension.cmx odoc_exception.cmx odoc_class.cmx odoc_search.cmo : odoc_value.cmo odoc_types.cmi odoc_type.cmo \ - odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_extension.cmo \ - odoc_exception.cmo odoc_class.cmo odoc_search.cmi + odoc_module.cmo odoc_extension.cmo odoc_exception.cmo odoc_class.cmo \ + odoc_search.cmi odoc_search.cmx : odoc_value.cmx odoc_types.cmx odoc_type.cmx \ - odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_extension.cmx \ - odoc_exception.cmx odoc_class.cmx odoc_search.cmi + odoc_module.cmx odoc_extension.cmx odoc_exception.cmx odoc_class.cmx \ + odoc_search.cmi +odoc_search.cmi : odoc_value.cmo odoc_types.cmi odoc_type.cmo \ + odoc_module.cmo odoc_extension.cmo odoc_exception.cmo odoc_class.cmo odoc_see_lexer.cmo : odoc_parser.cmi odoc_see_lexer.cmx : odoc_parser.cmx odoc_sig.cmo : ../typing/types.cmi ../typing/typedtree.cmi \ - ../typing/path.cmi ../parsing/parsetree.cmi odoc_value.cmo odoc_types.cmi \ - odoc_type.cmo odoc_parameter.cmo odoc_name.cmi odoc_module.cmo \ - odoc_misc.cmi odoc_messages.cmo odoc_merge.cmi odoc_global.cmi \ - odoc_extension.cmo odoc_exception.cmo odoc_env.cmi odoc_class.cmo \ - ../utils/misc.cmi ../parsing/location.cmi ../typing/ident.cmi \ - ../typing/ctype.cmi ../typing/btype.cmi ../parsing/asttypes.cmi \ - odoc_sig.cmi + ../parsing/parsetree.cmi odoc_value.cmo odoc_types.cmi odoc_type.cmo \ + odoc_parameter.cmo odoc_module.cmo odoc_misc.cmi odoc_messages.cmo \ + odoc_merge.cmi odoc_global.cmi odoc_extension.cmo odoc_exception.cmo \ + odoc_env.cmi odoc_class.cmo ../utils/misc.cmi ../parsing/location.cmi \ + ../typing/ident.cmi ../typing/ctype.cmi ../typing/btype.cmi \ + ../parsing/asttypes.cmi odoc_sig.cmi odoc_sig.cmx : ../typing/types.cmx ../typing/typedtree.cmx \ - ../typing/path.cmx ../parsing/parsetree.cmi odoc_value.cmx odoc_types.cmx \ - odoc_type.cmx odoc_parameter.cmx odoc_name.cmx odoc_module.cmx \ - odoc_misc.cmx odoc_messages.cmx odoc_merge.cmx odoc_global.cmx \ - odoc_extension.cmx odoc_exception.cmx odoc_env.cmx odoc_class.cmx \ - ../utils/misc.cmx ../parsing/location.cmx ../typing/ident.cmx \ - ../typing/ctype.cmx ../typing/btype.cmx ../parsing/asttypes.cmi \ - odoc_sig.cmi + ../parsing/parsetree.cmi odoc_value.cmx odoc_types.cmx odoc_type.cmx \ + odoc_parameter.cmx odoc_module.cmx odoc_misc.cmx odoc_messages.cmx \ + odoc_merge.cmx odoc_global.cmx odoc_extension.cmx odoc_exception.cmx \ + odoc_env.cmx odoc_class.cmx ../utils/misc.cmx ../parsing/location.cmx \ + ../typing/ident.cmx ../typing/ctype.cmx ../typing/btype.cmx \ + ../parsing/asttypes.cmi odoc_sig.cmi +odoc_sig.cmi : ../typing/types.cmi ../typing/typedtree.cmi \ + ../parsing/parsetree.cmi odoc_types.cmi odoc_type.cmo odoc_name.cmi \ + odoc_module.cmo odoc_env.cmi odoc_class.cmo odoc_str.cmo : ../typing/types.cmi ../typing/printtyp.cmi odoc_value.cmo \ odoc_type.cmo odoc_print.cmi odoc_name.cmi odoc_misc.cmi \ odoc_messages.cmo odoc_extension.cmo odoc_exception.cmo odoc_class.cmo \ @@ -208,6 +231,8 @@ odoc_str.cmx : ../typing/types.cmx ../typing/printtyp.cmx odoc_value.cmx \ odoc_type.cmx odoc_print.cmx odoc_name.cmx odoc_misc.cmx \ odoc_messages.cmx odoc_extension.cmx odoc_exception.cmx odoc_class.cmx \ ../parsing/asttypes.cmi odoc_str.cmi +odoc_str.cmi : ../typing/types.cmi odoc_value.cmo odoc_type.cmo \ + odoc_extension.cmo odoc_exception.cmo odoc_class.cmo odoc_test.cmo : odoc_info.cmi odoc_gen.cmi odoc_args.cmi odoc_test.cmx : odoc_info.cmx odoc_gen.cmx odoc_args.cmx odoc_texi.cmo : ../typing/types.cmi odoc_to_text.cmo odoc_messages.cmo \ @@ -218,52 +243,24 @@ odoc_text.cmo : odoc_types.cmi odoc_text_parser.cmi odoc_text_lexer.cmo \ odoc_text.cmi odoc_text.cmx : odoc_types.cmx odoc_text_parser.cmx odoc_text_lexer.cmx \ odoc_text.cmi +odoc_text.cmi : odoc_types.cmi odoc_text_lexer.cmo : odoc_text_parser.cmi odoc_misc.cmi odoc_text_lexer.cmx : odoc_text_parser.cmx odoc_misc.cmx odoc_text_parser.cmo : odoc_types.cmi odoc_misc.cmi odoc_text_parser.cmi odoc_text_parser.cmx : odoc_types.cmx odoc_misc.cmx odoc_text_parser.cmi -odoc_to_text.cmo : odoc_module.cmo odoc_messages.cmo odoc_info.cmi -odoc_to_text.cmx : odoc_module.cmx odoc_messages.cmx odoc_info.cmx +odoc_text_parser.cmi : odoc_types.cmi +odoc_to_text.cmo : odoc_str.cmi odoc_module.cmo odoc_messages.cmo \ + odoc_info.cmi +odoc_to_text.cmx : odoc_str.cmx odoc_module.cmx odoc_messages.cmx \ + odoc_info.cmx odoc_type.cmo : ../typing/types.cmi odoc_types.cmi odoc_name.cmi \ ../parsing/asttypes.cmi odoc_type.cmx : ../typing/types.cmx odoc_types.cmx odoc_name.cmx \ ../parsing/asttypes.cmi odoc_types.cmo : odoc_messages.cmo ../parsing/location.cmi odoc_types.cmi odoc_types.cmx : odoc_messages.cmx ../parsing/location.cmx odoc_types.cmi +odoc_types.cmi : ../parsing/location.cmi odoc_value.cmo : ../typing/types.cmi ../typing/printtyp.cmi odoc_types.cmi \ odoc_parameter.cmo odoc_name.cmi odoc_misc.cmi ../parsing/asttypes.cmi odoc_value.cmx : ../typing/types.cmx ../typing/printtyp.cmx odoc_types.cmx \ odoc_parameter.cmx odoc_name.cmx odoc_misc.cmx ../parsing/asttypes.cmi -odoc_analyse.cmi : odoc_module.cmo odoc_global.cmi -odoc_args.cmi : odoc_gen.cmi -odoc_ast.cmi : ../typing/types.cmi ../typing/typedtree.cmi \ - ../parsing/parsetree.cmi odoc_sig.cmi odoc_name.cmi odoc_module.cmo -odoc_comments.cmi : odoc_types.cmi odoc_module.cmo -odoc_comments_global.cmi : -odoc_config.cmi : -odoc_cross.cmi : odoc_types.cmi odoc_module.cmo -odoc_dag2html.cmi : odoc_info.cmi -odoc_env.cmi : ../typing/types.cmi odoc_name.cmi -odoc_gen.cmi : odoc_texi.cmo odoc_module.cmo odoc_man.cmo odoc_latex.cmo \ - odoc_html.cmo odoc_dot.cmo -odoc_global.cmi : odoc_types.cmi -odoc_info.cmi : ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ - odoc_type.cmo odoc_search.cmi odoc_parameter.cmo odoc_module.cmo \ - odoc_global.cmi odoc_extension.cmo odoc_exception.cmo odoc_class.cmo \ - ../parsing/location.cmi ../parsing/asttypes.cmi -odoc_merge.cmi : odoc_types.cmi odoc_module.cmo -odoc_misc.cmi : ../typing/types.cmi odoc_types.cmi ../parsing/longident.cmi \ - ../parsing/asttypes.cmi -odoc_name.cmi : ../typing/path.cmi ../parsing/longident.cmi \ - ../typing/ident.cmi -odoc_parser.cmi : odoc_types.cmi -odoc_print.cmi : ../typing/types.cmi -odoc_search.cmi : odoc_value.cmo odoc_types.cmi odoc_type.cmo \ - odoc_module.cmo odoc_extension.cmo odoc_exception.cmo odoc_class.cmo -odoc_sig.cmi : ../typing/types.cmi ../parsing/parsetree.cmi odoc_types.cmi \ - odoc_type.cmo odoc_name.cmi odoc_module.cmo odoc_env.cmi odoc_class.cmo -odoc_str.cmi : ../typing/types.cmi odoc_value.cmo odoc_type.cmo \ - odoc_extension.cmo odoc_exception.cmo odoc_class.cmo -odoc_text.cmi : odoc_types.cmi -odoc_text_parser.cmi : odoc_types.cmi -odoc_types.cmi : ../parsing/location.cmi diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile index 2eba14c1..7b53a036 100644 --- a/ocamldoc/Makefile +++ b/ocamldoc/Makefile @@ -75,7 +75,6 @@ INCLUDES_DEP=-I $(OCAMLSRCDIR)/parsing \ -I $(OCAMLSRCDIR)/typing \ -I $(OCAMLSRCDIR)/driver \ -I $(OCAMLSRCDIR)/bytecomp \ - -I $(OCAMLSRCDIR)/tools \ -I $(OCAMLSRCDIR)/toplevel/ INCLUDES_NODEP= -I $(OCAMLSRCDIR)/stdlib \ @@ -87,7 +86,7 @@ INCLUDES_NODEP= -I $(OCAMLSRCDIR)/stdlib \ INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP) -COMPFLAGS=$(INCLUDES) -warn-error A -safe-string +COMPFLAGS=$(INCLUDES) -absname -w +a-4-9-41-42-44-45-48 -warn-error A -safe-string -strict-sequence -strict-formats LINKFLAGS=$(INCLUDES) -nostdlib CMOFILES= odoc_config.cmo \ @@ -151,13 +150,6 @@ LIBCMOFILES=$(CMOFILES) LIBCMXFILES= $(LIBCMOFILES:.cmo=.cmx) LIBCMIFILES= $(LIBCMOFILES:.cmo=.cmi) -# Les cmo et cmx de la distrib OCAML -OCAMLCMOFILES= \ - $(OCAMLSRCDIR)/tools/depend.cmo - -OCAMLCMXFILES=$(OCAMLCMOFILES:.cmo=.cmx) - - STDLIB_MLIS=../stdlib/*.mli \ ../parsing/*.mli \ ../otherlibs/$(UNIXLIB)/unix.mli \ @@ -190,17 +182,17 @@ debug: $(OCAMLDOC): $(EXECMOFILES) $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma \ $(OCAMLSRCDIR)/compilerlibs/ocamlcommon.cma \ - $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES) + $(LINKFLAGS) $(EXECMOFILES) $(OCAMLDOC_OPT): $(EXECMXFILES) $(OCAMLOPT) -o $@ -linkall unix.cmxa str.cmxa dynlink.cmxa \ $(OCAMLSRCDIR)/compilerlibs/ocamlcommon.cmxa \ - $(LINKFLAGS) $(OCAMLCMXFILES) $(EXECMXFILES) + $(LINKFLAGS) $(EXECMXFILES) $(OCAMLDOC_LIBCMA): $(LIBCMOFILES) - $(OCAMLC) -a -o $@ $(LINKFLAGS) $(OCAMLSRCDIR)/tools/depend.cmo \ + $(OCAMLC) -a -o $@ $(LINKFLAGS) \ $(LIBCMOFILES) $(OCAMLDOC_LIBCMXA): $(LIBCMXFILES) - $(OCAMLOPT) -a -o $@ $(LINKFLAGS) $(OCAMLSRCDIR)/tools/depend.cmx \ + $(OCAMLOPT) -a -o $@ $(LINKFLAGS) \ $(LIBCMXFILES) manpages: stdlib_man/Pervasives.3o diff --git a/ocamldoc/Makefile.nt b/ocamldoc/Makefile.nt index 6a993e32..7bb17e25 100644 --- a/ocamldoc/Makefile.nt +++ b/ocamldoc/Makefile.nt @@ -61,7 +61,6 @@ INCLUDES_DEP=-I $(OCAMLSRCDIR)/parsing \ -I $(OCAMLSRCDIR)/typing \ -I $(OCAMLSRCDIR)/driver \ -I $(OCAMLSRCDIR)/bytecomp \ - -I $(OCAMLSRCDIR)/tools \ -I $(OCAMLSRCDIR)/toplevel/ INCLUDES_NODEP= -I $(OCAMLSRCDIR)/stdlib \ @@ -73,7 +72,7 @@ INCLUDES_NODEP= -I $(OCAMLSRCDIR)/stdlib \ INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP) -COMPFLAGS=$(INCLUDES) -warn-error A -safe-string +COMPFLAGS=$(INCLUDES) -absname -w +a-4-9-41-42-44-45-48 -warn-error A -safe-string -strict-sequence -strict-formats LINKFLAGS=$(INCLUDES) -nostdlib CMOFILES= odoc_config.cmo \ @@ -137,12 +136,6 @@ LIBCMOFILES=$(CMOFILES) LIBCMXFILES= $(LIBCMOFILES:.cmo=.cmx) LIBCMIFILES= $(LIBCMOFILES:.cmo=.cmi) -# Les cmo et cmx de la distrib OCAML -OCAMLCMOFILES= \ - $(OCAMLSRCDIR)/tools/depend.cmo - -OCAMLCMXFILES=$(OCAMLCMOFILES:.cmo=.cmx) - all: $(MAKEREC) exe $(MAKEREC) lib @@ -160,17 +153,17 @@ debug: $(OCAMLDOC): $(EXECMOFILES) $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma \ $(OCAMLSRCDIR)/compilerlibs/ocamlcommon.cma \ - $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES) + $(LINKFLAGS) $(EXECMOFILES) $(OCAMLDOC_OPT): $(EXECMXFILES) $(OCAMLOPT) -o $@ -linkall unix.cmxa str.cmxa dynlink.cmxa \ $(OCAMLSRCDIR)/compilerlibs/ocamlcommon.cmxa \ - $(LINKFLAGS) $(OCAMLCMXFILES) $(EXECMXFILES) + $(LINKFLAGS) $(EXECMXFILES) $(OCAMLDOC_LIBCMA): $(LIBCMOFILES) - $(OCAMLC) -a -o $@ $(LINKFLAGS) $(OCAMLSRCDIR)/tools/depend.cmo \ + $(OCAMLC) -a -o $@ $(LINKFLAGS) \ $(LIBCMOFILES) $(OCAMLDOC_LIBCMXA): $(LIBCMXFILES) - $(OCAMLOPT) -a -o $@ $(LINKFLAGS) $(OCAMLSRCDIR)/tools/depend.cmx \ + $(OCAMLOPT) -a -o $@ $(LINKFLAGS) \ $(LIBCMXFILES) # Parsers and lexers dependencies : @@ -256,7 +249,7 @@ depend:: $(OCAMLLEX) odoc_lexer.mll $(OCAMLLEX) odoc_ocamlhtml.mll $(OCAMLLEX) odoc_see_lexer.mll - $(OCAMLDEP) $(INCLUDES_DEP) *.mll *.mly *.ml *.mli > .depend + $(OCAMLDEP) -slash $(INCLUDES_DEP) *.mll *.mly *.ml *.mli > .depend dummy: diff --git a/ocamldoc/generators/odoc_literate.ml b/ocamldoc/generators/odoc_literate.ml index da71b9ef..aec19808 100644 --- a/ocamldoc/generators/odoc_literate.ml +++ b/ocamldoc/generators/odoc_literate.ml @@ -16,7 +16,6 @@ open Odoc_info module Naming = Odoc_html.Naming open Odoc_info.Value -open Odoc_info.Module let p = Printf.bprintf let bp = Printf.bprintf @@ -38,20 +37,20 @@ module Generator = struct class html = object (self) - inherit Html.html as html + inherit Html.html - method private html_of_module_comment b text = + method! private html_of_module_comment b text = let br1, br2 = match text with - [(Odoc_info.Title (n, l_opt, t))] -> false, false - | (Odoc_info.Title (n, l_opt, t)) :: _ -> false, true + [(Odoc_info.Title _)] -> false, false + | (Odoc_info.Title _) :: _ -> false, true | _ -> true, true in if br1 then p b "
"; self#html_of_text b text; if br2 then p b "

\n" - method private html_of_Title b n l_opt t = + method! private html_of_Title b n l_opt t = let label1 = self#create_title_label (n, l_opt, t) in p b "\n" (Naming.label_target label1); p b "" n; @@ -75,7 +74,7 @@ class html = Printf.bprintf b "" (** Print html code for a value. *) - method private html_of_value b v = + method! private html_of_value b v = Odoc_info.reset_type_names (); self#html_of_info b v.val_info; bs b "
";
diff --git a/ocamldoc/generators/odoc_todo.ml b/ocamldoc/generators/odoc_todo.ml
index 01d3d94a..d404e9b0 100644
--- a/ocamldoc/generators/odoc_todo.ml
+++ b/ocamldoc/generators/odoc_todo.ml
@@ -107,44 +107,44 @@ struct
                 l;
               p b ""
 
-    method scan_value v =
+    method! scan_value v =
       self#gen_if_tag
         v.val_name
         (Odoc_html.Naming.complete_value_target v)
         v.val_info
 
-    method scan_type t =
+    method! scan_type t =
       self#gen_if_tag
         t.ty_name
         (Odoc_html.Naming.complete_type_target t)
         t.ty_info
 
-    method scan_extension_constructor x =
+    method! scan_extension_constructor x =
       self#gen_if_tag
         x.xt_name
         (Odoc_html.Naming.complete_extension_target x)
         x.xt_type_extension.te_info
 
-    method scan_exception e =
+    method! scan_exception e =
       self#gen_if_tag
         e.ex_name
         (Odoc_html.Naming.complete_exception_target e)
         e.ex_info
 
-    method scan_attribute a =
+    method! scan_attribute a =
       self#gen_if_tag
         a.att_value.val_name
         (Odoc_html.Naming.complete_attribute_target a)
         a.att_value.val_info
 
-    method scan_method m =
+    method! scan_method m =
       self#gen_if_tag
         m.met_value.val_name
         (Odoc_html.Naming.complete_method_target m)
         m.met_value.val_info
 
    (** This method scan the elements of the given module. *)
-    method scan_module_elements m =
+    method! scan_module_elements m =
       List.iter
         (fun ele ->
           match ele with
@@ -161,30 +161,30 @@ struct
         )
         (Odoc_module.module_elements ~trans: false m)
 
-    method scan_included_module _ = ()
+    method! scan_included_module _ = ()
 
-    method scan_class_pre c =
+    method! scan_class_pre c =
       self#gen_if_tag
         c.cl_name
         (fst (Odoc_html.Naming.html_files c.cl_name))
         c.cl_info;
       true
 
-    method scan_class_type_pre ct =
+    method! scan_class_type_pre ct =
       self#gen_if_tag
         ct.clt_name
         (fst (Odoc_html.Naming.html_files ct.clt_name))
         ct.clt_info;
       true
 
-    method scan_module_pre m =
+    method! scan_module_pre m =
       self#gen_if_tag
         m.m_name
         (fst (Odoc_html.Naming.html_files m.m_name))
         m.m_info;
       true
 
-    method scan_module_type_pre mt =
+    method! scan_module_type_pre mt =
       self#gen_if_tag
         mt.mt_name
         (fst (Odoc_html.Naming.html_files mt.mt_name))
@@ -202,7 +202,7 @@ struct
              html generator class *)
       val mutable scanner = new scanner (new Html.html )
 
-      method generate modules =
+      method! generate modules =
       (* prevent having the 'todo' tag signaled as not handled *)
       tag_functions <-  ("todo", (fun _ -> "")) :: tag_functions;
       (* generate doc as usual *)
diff --git a/ocamldoc/ocamldoc.hva b/ocamldoc/ocamldoc.hva
index 2bbddc06..cd5bce0f 100644
--- a/ocamldoc/ocamldoc.hva
+++ b/ocamldoc/ocamldoc.hva
@@ -20,7 +20,7 @@
 \newcommand\textbar{|}
 \newcommand\textbackslash{\begin{rawhtml}\\end{rawhtml}}
 \newcommand\textasciicircum{\^{}}
-\newcommand\sharp{#}
+\newcommand\hash{#}
 
 \let\ocamldocvspace\vspace
 \newenvironment{ocamldocindent}{\list{}{}\item\relax}{\endlist}
diff --git a/ocamldoc/odoc.ml b/ocamldoc/odoc.ml
index 45c3847a..b49aa1b1 100644
--- a/ocamldoc/odoc.ml
+++ b/ocamldoc/odoc.ml
@@ -16,12 +16,6 @@
 (** Main module for bytecode.
 @todo todo*)
 
-open Config
-open Clflags
-open Misc
-open Format
-open Typedtree
-
 module M = Odoc_messages
 
 let print_DEBUG s = print_string s ; print_newline ()
diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml
index c0b88bee..a166cd9b 100644
--- a/ocamldoc/odoc_analyse.ml
+++ b/ocamldoc/odoc_analyse.ml
@@ -18,9 +18,6 @@
 
 let print_DEBUG s = print_string s ; print_newline ()
 
-open Config
-open Clflags
-open Misc
 open Format
 open Typedtree
 
@@ -30,7 +27,7 @@ open Typedtree
    then the directories specified with the -I option (in command-line order),
    then the standard library directory. *)
 let init_path () =
-  load_path :=
+  Config.load_path :=
     "" :: List.rev (Config.standard_library :: !Clflags.include_dirs);
   Env.reset_cache ()
 
@@ -40,11 +37,24 @@ let initial_env () =
     if !Clflags.unsafe_string then Env.initial_unsafe_string
     else Env.initial_safe_string
   in
-  try
-    if !Clflags.nopervasives then initial else
-    Env.open_pers_signature "Pervasives" initial
-  with Not_found ->
-    fatal_error "cannot open pervasives.cmi"
+  let initial =
+    (* Open the Pervasives module by reading directly the corresponding cmi
+       file to avoid troubles when building the documentation for the
+       Pervasives modules.
+       Another option might be to add a -nopervasives option to ocamldoc and update
+       stdlib documentation's build process. *)
+    try
+      Env.open_pers_signature "Pervasives" initial
+    with Not_found ->
+      Misc.fatal_error @@ Printf.sprintf "cannot open pervasives.cmi" in
+  let open_mod env m =
+    let open Asttypes in
+    let lid = {loc = Location.in_file "ocamldoc command line";
+               txt = Longident.Lident m } in
+    snd (Typemod.type_open_ Override env lid.loc lid) in
+  (* Open the list of modules given as arguments of the "-open" flag
+     The list is reversed to open the modules in the left-to-right order *)
+  List.fold_left open_mod initial (List.rev !Clflags.open_modules)
 
 (** Optionally preprocess a source file *)
 let preprocess sourcefile =
@@ -55,8 +65,6 @@ let preprocess sourcefile =
       Pparse.report_error err;
     exit 2
 
-let (++) x f = f x
-
 (** Analysis of an implementation file. Returns (Some typedtree) if
    no error occured, else None and an error message is printed.*)
 
@@ -69,7 +77,7 @@ let no_docstring f x =
   Lexer.handle_docstrings := true;
   result
 
-let process_implementation_file ppf sourcefile =
+let process_implementation_file sourcefile =
   init_path ();
   let prefixname = Filename.chop_extension sourcefile in
   let modulename = String.capitalize_ascii(Filename.basename prefixname) in
@@ -79,7 +87,7 @@ let process_implementation_file ppf sourcefile =
   try
     let parsetree =
       Pparse.file ~tool_name Format.err_formatter inputfile
-        (no_docstring Parse.implementation) ast_impl_magic_number
+        (no_docstring Parse.implementation) Pparse.Structure
     in
     let typedtree =
       Typemod.type_implementation
@@ -102,7 +110,7 @@ let process_implementation_file ppf sourcefile =
 
 (** Analysis of an interface file. Returns (Some signature) if
    no error occured, else None and an error message is printed.*)
-let process_interface_file ppf sourcefile =
+let process_interface_file sourcefile =
   init_path ();
   let prefixname = Filename.chop_extension sourcefile in
   let modulename = String.capitalize_ascii(Filename.basename prefixname) in
@@ -110,9 +118,9 @@ let process_interface_file ppf sourcefile =
   let inputfile = preprocess sourcefile in
   let ast =
     Pparse.file ~tool_name Format.err_formatter inputfile
-      (no_docstring Parse.interface) ast_intf_magic_number
+      (no_docstring Parse.interface) Pparse.Signature
   in
-  let sg = Typemod.type_interface (initial_env()) ast in
+  let sg = Typemod.type_interface sourcefile (initial_env()) ast in
   Warnings.check_fatal ();
   (ast, sg, inputfile)
 
@@ -134,7 +142,7 @@ let process_error exn =
         (Printexc.to_string exn)
 
 (** Process the given file, according to its extension. Return the Module.t created, if any.*)
-let process_file ppf sourcefile =
+let process_file sourcefile =
   if !Odoc_global.verbose then
     (
      let f = match sourcefile with
@@ -150,7 +158,7 @@ let process_file ppf sourcefile =
       (
        Location.input_name := file;
        try
-         let (parsetree_typedtree_opt, input_file) = process_implementation_file ppf file in
+         let (parsetree_typedtree_opt, input_file) = process_implementation_file file in
          match parsetree_typedtree_opt with
            None ->
              None
@@ -182,7 +190,7 @@ let process_file ppf sourcefile =
       (
        Location.input_name := file;
        try
-         let (ast, signat, input_file) = process_interface_file ppf file in
+         let (ast, signat, input_file) = process_interface_file file in
          let file_module = Sig_analyser.analyse_signature file
              !Location.input_name ast signat.sig_type
          in
@@ -394,7 +402,7 @@ let analyse_files ?(init=[]) files =
     (List.fold_left
        (fun acc -> fun file ->
          try
-           match process_file Format.err_formatter file with
+           match process_file file with
              None ->
                acc
            | Some m ->
diff --git a/ocamldoc/odoc_args.ml b/ocamldoc/odoc_args.ml
index f2d7862e..039c8d70 100644
--- a/ocamldoc/odoc_args.ml
+++ b/ocamldoc/odoc_args.ml
@@ -222,6 +222,8 @@ module Options = Main_args.Make_ocamldoc_options(struct
   let _no_strict_formats = unset Clflags.strict_formats
   let _thread = set Clflags.use_threads
   let _vmthread = set Clflags.use_vmthreads
+  let _unboxed_types = set Clflags.unboxed_types
+  let _no_unboxed_types = unset Clflags.unboxed_types
   let _unsafe () = assert false
   let _unsafe_string = set Clflags.unsafe_string
   let _v () = Compenv.print_version_and_library "documentation generator"
@@ -306,8 +308,8 @@ let default_options = Options.list @
     M.generate_dot ;
   "-customdir", Arg.Unit (fun () -> Printf.printf "%s\n" Odoc_config.custom_generators_path; exit 0),
   M.display_custom_generators_dir ;
-  "-i", Arg.String (fun s -> ()), M.add_load_dir ;
-  "-g", Arg.String (fun s -> ()), M.load_file ^
+  "-i", Arg.String (fun _ -> ()), M.add_load_dir ;
+  "-g", Arg.String (fun _ -> ()), M.load_file ^
   "\n\n *** HTML options ***\n";
 
 (* html only options *)
diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml
index d5817612..d987485c 100644
--- a/ocamldoc/odoc_ast.ml
+++ b/ocamldoc/odoc_ast.ml
@@ -24,7 +24,6 @@ let print_DEBUG s = print_string s ; print_newline ();;
 
 type typedtree = (Typedtree.structure * Typedtree.module_coercion)
 
-module Name = Odoc_name
 open Odoc_parameter
 open Odoc_value
 open Odoc_type
@@ -34,12 +33,6 @@ open Odoc_class
 open Odoc_module
 open Odoc_types
 
-(** This variable contains the regular expression representing a blank.*)
-let blank = "[ \010\013\009\012']"
-
-(** This variable contains the regular expression representing a blank but not a '\n'.*)
-let simple_blank = "[ \013\009\012]"
-
 (** This module is used to search for structure items by name in a Typedtree.structure.
    One function creates two hash tables, which can then be used to search for elements.
    Class elements do not use tables.
@@ -55,7 +48,6 @@ module Typedtree_search =
       | X of string
       | E of string
       | P of string
-      | IM of string
 
     type tab = (ele, Typedtree.structure_item_desc) Hashtbl.t
     type tab_values = (Odoc_module.Name.t, Typedtree.pattern * Typedtree.expression) Hashtbl.t
@@ -100,7 +92,7 @@ module Typedtree_search =
             info_list
       | Typedtree.Tstr_class_type info_list ->
           List.iter
-            (fun ((id,id_loc,_) as ci) ->
+            (fun ((id,_,_) as ci) ->
               Hashtbl.add table
                 (CT (Name.from_ident id))
                 (Typedtree.Tstr_class_type [ci]))
@@ -192,10 +184,10 @@ module Typedtree_search =
       let rec iter = function
         | [] ->
             raise Not_found
-        | { cf_desc = Typedtree.Tcf_val (_, _, ident, Tcfk_concrete (_, exp), _) } :: q
+        | { cf_desc = Typedtree.Tcf_val (_, _, ident, Tcfk_concrete (_, exp), _) } :: _
           when Name.from_ident ident = name ->
             exp.Typedtree.exp_type
-        | { cf_desc = Typedtree.Tcf_val (_, _, ident, Tcfk_virtual typ, _) } :: q
+        | { cf_desc = Typedtree.Tcf_val (_, _, ident, Tcfk_virtual typ, _) } :: _
           when Name.from_ident ident = name ->
             typ.Typedtree.ctyp_type
         | _ :: q ->
@@ -203,19 +195,11 @@ module Typedtree_search =
       in
       iter cls.Typedtree.cstr_fields
 
-    let class_sig_of_cltype_decl =
-      let rec iter = function
-        Types.Cty_constr (_, _, cty) -> iter cty
-      | Types.Cty_signature s -> s
-      | Types.Cty_arrow (_,_, cty) -> iter cty
-      in
-      fun ct_decl -> iter ct_decl.Types.clty_type
-
    let search_method_expression cls name =
       let rec iter = function
         | [] ->
             raise Not_found
-        | { cf_desc = Typedtree.Tcf_method (label, _, Tcfk_concrete (_, exp)) } :: q when label.txt = name ->
+        | { cf_desc = Typedtree.Tcf_method (label, _, Tcfk_concrete (_, exp)) } :: _ when label.txt = name ->
             exp
         | _ :: q ->
             iter q
@@ -304,7 +288,7 @@ module Analyser =
           (* This case means we have a 'function' without pattern, that's impossible *)
           raise (Failure "tt_analyse_function_parameters: 'function' without pattern")
 
-      | {c_lhs=pattern_param} :: second_ele :: q ->
+      | {c_lhs=pattern_param} :: _second_ele :: _ ->
           (* implicit pattern matching -> anonymous parameter and no more parameter *)
           (* FIXME : label ? *)
           let parameter = Odoc_parameter.Tuple ([], Odoc_env.subst_type env pattern_param.pat_type) in
@@ -358,7 +342,7 @@ module Analyser =
      let tt_analyse_value env current_module_name comment_opt loc pat_exp rec_flag =
        let (pat, exp) = pat_exp in
        match (pat.pat_desc, exp.exp_desc) with
-         (Typedtree.Tpat_var (ident, _), Typedtree.Texp_function (_, pat_exp_list2, partial)) ->
+         (Typedtree.Tpat_var (ident, _), Typedtree.Texp_function (_, pat_exp_list2, _partial)) ->
            (* a new function is defined *)
            let name_pre = Name.from_ident ident in
            let name = Name.parens_if_infix name_pre in
@@ -407,7 +391,7 @@ module Analyser =
            in
            [ new_value ]
 
-       | (Typedtree.Tpat_tuple lpat, _) ->
+       | (Typedtree.Tpat_tuple _, _) ->
            (* new identifiers are defined *)
            (* FIXME : by now we don't accept to have global variables defined in tuples *)
            []
@@ -459,7 +443,7 @@ module Analyser =
                  [] ->
                    (* impossible case, it has already been filtered *)
                    assert false
-               | {c_lhs=pattern_param} :: second_ele :: q ->
+               | {c_lhs=pattern_param} :: _second_ele :: _ ->
                    (* implicit pattern matching -> anonymous parameter *)
                    (* Note : We can't match this pattern if it is the first call to the function. *)
                    let new_param = Simple_name
@@ -517,7 +501,7 @@ module Analyser =
 
     (** Analysis of a [Parsetree.class_struture] and a [Typedtree.class_structure] to get a couple
        (inherited classes, class elements). *)
-    let analyse_class_structure env current_class_name tt_class_sig last_pos pos_limit p_cls tt_cls table =
+    let analyse_class_structure env current_class_name tt_class_sig last_pos pos_limit p_cls tt_cls _table =
       let rec iter acc_inher acc_fields last_pos = function
         | [] ->
             let s = get_string_of_file last_pos pos_limit in
@@ -709,7 +693,7 @@ module Analyser =
              however they can be found in the class_type *)
           let params =
             match tt_class_exp.Typedtree.cl_type with
-              Types.Cty_constr (p2, type_exp_list, cltyp) ->
+              Types.Cty_constr (_p2, type_exp_list, _cltyp) ->
                 (* cltyp is the class type for [type_exp_list] p *)
                 type_exp_list
             | _ ->
@@ -743,8 +727,8 @@ module Analyser =
           ([],
            Class_structure (inherited_classes, class_elements) )
 
-      | (Parsetree.Pcl_fun (label, expression_opt, pattern, p_class_expr2),
-         Typedtree.Tcl_fun (_, pat, ident_exp_list, tt_class_expr2, partial)) ->
+      | (Parsetree.Pcl_fun (_label, _expression_opt, _pattern, p_class_expr2),
+         Typedtree.Tcl_fun (_, pat, _ident_exp_list, tt_class_expr2, _partial)) ->
            (* we check that this is not an optional parameter with
               a default value. In this case, we look for the good parameter pattern *)
            let (parameter, next_tt_class_exp) =
@@ -829,7 +813,7 @@ module Analyser =
               env current_class_name comment_opt last_pos p_class_expr2
               tt_class_expr2 table
 
-      | (Parsetree.Pcl_constraint (p_class_expr2, p_class_type2),
+      | (Parsetree.Pcl_constraint (p_class_expr2, _p_class_type2),
          Typedtree.Tcl_constraint (tt_class_expr2, _, _, _, _)) ->
           let (l, class_kind) = analyse_class_kind
               env current_class_name comment_opt last_pos p_class_expr2
@@ -1077,7 +1061,7 @@ module Analyser =
       iter env last_pos parsetree
 
    (** Analysis of a parse tree structure item to obtain a new environment and a list of elements.*)
-   and analyse_structure_item env current_module_name loc pos_limit comment_opt parsetree_item_desc typedtree
+   and analyse_structure_item env current_module_name loc pos_limit comment_opt parsetree_item_desc _typedtree
         table table_values =
       print_DEBUG "Odoc_ast:analyse_struture_item";
       match parsetree_item_desc with
@@ -1318,10 +1302,7 @@ module Analyser =
                       match tt_ext.ext_kind with
                           Text_decl(args, ret_type) ->
                           let xt_args =
-                            match args with
-                            | Cstr_tuple l -> Cstr_tuple (List.map (fun ctyp -> Odoc_env.subst_type new_env ctyp.ctyp_type) l)
-                            | Cstr_record _ -> assert false
-                          in
+                            Sig.get_cstr_args new_env ext_loc_end args in
                             {
                               xt_name = complete_name;
                               xt_args;
@@ -1379,10 +1360,7 @@ module Analyser =
                 let loc_start = loc.Location.loc_start.Lexing.pos_cnum in
                 let loc_end =  loc.Location.loc_end.Lexing.pos_cnum in
                 let ex_args =
-                  match tt_args with
-                  | Cstr_tuple l -> Cstr_tuple (List.map (fun c -> Odoc_env.subst_type env c.ctyp_type) l)
-                  | Cstr_record l -> assert false (* TODO *)
-                in
+                  Sig.get_cstr_args env loc_end tt_args in
                 {
                   ex_name = complete_name ;
                   ex_info = comment_opt ;
@@ -1668,7 +1646,7 @@ module Analyser =
           in
           (0, new_env, f ~first: true loc.Location.loc_start.Lexing.pos_cnum class_type_decl_list)
 
-      | Parsetree.Pstr_include incl ->
+      | Parsetree.Pstr_include _ ->
           (* we add a dummy included module which will be replaced by a correct
              one at the end of the module analysis,
              to use the Path.t of the included modules in the typdtree. *)
@@ -1716,8 +1694,8 @@ module Analyser =
       }
       in
       match (p_module_expr.Parsetree.pmod_desc, tt_module_expr.Typedtree.mod_desc) with
-        (Parsetree.Pmod_ident longident, Typedtree.Tmod_ident (path, _))
-        | (Parsetree.Pmod_ident longident,
+        (Parsetree.Pmod_ident _, Typedtree.Tmod_ident (path, _))
+        | (Parsetree.Pmod_ident _,
            Typedtree.Tmod_constraint
              ({Typedtree.mod_desc = Typedtree.Tmod_ident (path, _)}, _, _, _))
           ->
@@ -1838,7 +1816,7 @@ module Analyser =
           }
 
       | (Parsetree.Pmod_unpack p_exp,
-         Typedtree.Tmod_unpack (t_exp, tt_modtype)) ->
+         Typedtree.Tmod_unpack (_t_exp, tt_modtype)) ->
           print_DEBUG ("Odoc_ast: case Parsetree.Pmod_unpack + Typedtree.Tmod_unpack "^module_name);
           let code =
             let loc = p_module_expr.Parsetree.pmod_loc in
@@ -1861,9 +1839,9 @@ module Analyser =
             m_kind = Module_unpack (code, alias) ;
           }
 
-      | (parsetree, typedtree) ->
+      | (_parsetree, _typedtree) ->
           (*DEBUG*)let s_parse =
-          (*DEBUG*)  match parsetree with
+          (*DEBUG*)  match _parsetree with
           (*DEBUG*)    Parsetree.Pmod_ident _ -> "Pmod_ident"
           (*DEBUG*)  | Parsetree.Pmod_structure _ -> "Pmod_structure"
           (*DEBUG*)  | Parsetree.Pmod_functor _ -> "Pmod_functor"
@@ -1873,7 +1851,7 @@ module Analyser =
           (*DEBUG*)  | Parsetree.Pmod_extension _ -> "Pmod_extension"
           (*DEBUG*)in
           (*DEBUG*)let s_typed =
-          (*DEBUG*)  match typedtree with
+          (*DEBUG*)  match _typedtree with
           (*DEBUG*)    Typedtree.Tmod_ident _ -> "Tmod_ident"
           (*DEBUG*)  | Typedtree.Tmod_structure _ -> "Tmod_structure"
           (*DEBUG*)  | Typedtree.Tmod_functor _ -> "Tmod_functor"
diff --git a/ocamldoc/odoc_class.ml b/ocamldoc/odoc_class.ml
index 5f9ca827..168071a9 100644
--- a/ocamldoc/odoc_class.ml
+++ b/ocamldoc/odoc_class.ml
@@ -114,7 +114,7 @@ let rec class_elements ?(trans=true) cl =
   let rec iter_kind k =
     match k with
       Class_structure (_, elements) -> elements
-    | Class_constraint (c_kind, ct_kind) ->
+    | Class_constraint (c_kind, _ct_kind) ->
         iter_kind c_kind
       (* FIXME : use c_kind or ct_kind ?
          For now, as ct_kind is not analyzed,
diff --git a/ocamldoc/odoc_comments.ml b/ocamldoc/odoc_comments.ml
index a8ef04e1..4ccd6dd1 100644
--- a/ocamldoc/odoc_comments.ml
+++ b/ocamldoc/odoc_comments.ml
@@ -31,7 +31,7 @@ module type Texter =
 module Info_retriever =
   functor (MyTexter : Texter) ->
   struct
-    let create_see file s =
+    let create_see _file s =
       try
         let lexbuf = Lexing.from_string s in
         let (see_ref, s) = Odoc_parser.see_info Odoc_see_lexer.main lexbuf in
@@ -100,31 +100,6 @@ module Info_retriever =
           (0, None)
         end
 
-    (** This function takes a string where a simple comment may has been found. It returns
-       false if there is a blank line or the first comment is a special one, or if there is
-       no comment if the string.*)
-    let nothing_before_simple_comment s =
-      (* get the position of the first "(*" *)
-      try
-        print_DEBUG ("comment_is_attached: "^s);
-        let pos = Str.search_forward (Str.regexp "(\\*") s 0 in
-        let next_char = if (String.length s) >= (pos + 1) then s.[pos + 2] else '_' in
-        (next_char <> '*') &&
-        (
-         (* there is no special comment between the constructor and the coment we got *)
-         let s2 = String.sub s 0 pos in
-         print_DEBUG ("s2="^s2);
-         try
-           let _ = Str.search_forward (Str.regexp ("['\n']"^simple_blank^"*['\n']")) s2 0 in
-           (* a blank line was before the comment *)
-           false
-         with
-           Not_found ->
-             true
-        )
-      with
-        Not_found ->
-          false
 
     (** Return true if the given string contains a blank line. *)
     let blank_line s =
@@ -139,14 +114,14 @@ module Info_retriever =
     let retrieve_info_special file (s : string) =
       retrieve_info Odoc_lexer.main file s
 
-    let retrieve_info_simple file (s : string) =
+    let retrieve_info_simple _file (s : string) =
       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
         None ->
           (0, None)
-      | Some (desc, remain_opt) ->
+      | Some _ ->
           (!Odoc_comments_global.nb_chars, Some Odoc_types.dummy_info)
 
     (** Return true if the given string contains a blank line outside a simple comment. *)
@@ -168,65 +143,6 @@ module Info_retriever =
       in
       iter s
 
-    (** This function returns the first simple comment in
-       the given string. If strict is [true] then no
-       comment is returned if a blank line or a special
-       comment is found before the simple comment. *)
-    let retrieve_first_info_simple ?(strict=true) file (s : string) =
-      match retrieve_info_simple file s with
-        (_, None) ->
-          (0, None)
-      | (len, Some d) ->
-          (* we check if the comment we got was really attached to the constructor,
-             i.e. that there was no blank line or any special comment "(**" before *)
-          if (not strict) || (nothing_before_simple_comment s) then
-            (* ok, we attach the comment to the constructor *)
-            (len, Some d)
-          else
-            (* a blank line or special comment was before the comment,
-               so we must not attach this comment to the constructor. *)
-            (0, None)
-
-    let retrieve_last_info_simple file (s : string) =
-      print_DEBUG ("retrieve_last_info_simple:"^s);
-      let rec f cur_len cur_d =
-        try
-          let s2 = String.sub s cur_len ((String.length s) - cur_len) in
-          print_DEBUG ("retrieve_last_info_simple.f:"^s2);
-          match retrieve_info_simple file s2 with
-            (len, None) ->
-              print_DEBUG "retrieve_last_info_simple: None";
-              (cur_len + len, cur_d)
-          | (len, Some d) ->
-              print_DEBUG "retrieve_last_info_simple: Some";
-              f (len + cur_len) (Some d)
-        with
-          _ ->
-            print_DEBUG "retrieve_last_info_simple : Erreur String.sub";
-            (cur_len, cur_d)
-      in
-      f 0 None
-
-    let retrieve_last_special_no_blank_after file (s : string) =
-      print_DEBUG ("retrieve_last_special_no_blank_after:"^s);
-      let rec f cur_len cur_d =
-        try
-          let s2 = String.sub s cur_len ((String.length s) - cur_len) in
-          print_DEBUG ("retrieve_last_special_no_blank_after.f:"^s2);
-          match retrieve_info_special file s2 with
-            (len, None) ->
-              print_DEBUG "retrieve_last_special_no_blank_after: None";
-              (cur_len + len, cur_d)
-          | (len, Some d) ->
-              print_DEBUG "retrieve_last_special_no_blank_after: Some";
-              f (len + cur_len) (Some d)
-        with
-          _ ->
-            print_DEBUG "retrieve_last_special_no_blank_after : Erreur String.sub";
-            (cur_len, cur_d)
-      in
-      f 0 None
-
     let all_special file s =
       print_DEBUG ("all_special: "^s);
       let rec iter acc n s2 =
@@ -270,7 +186,7 @@ module Info_retriever =
                    (* should not occur *)
                    (0, None)
               )
-          | (len2, Some d2) ->
+          | (_, Some _) ->
               (0, None)
       in
       print_DEBUG ("just_after_special:end");
diff --git a/ocamldoc/odoc_cross.ml b/ocamldoc/odoc_cross.ml
index 6949d339..4847e105 100644
--- a/ocamldoc/odoc_cross.ml
+++ b/ocamldoc/odoc_cross.ml
@@ -15,7 +15,6 @@
 
 (** Cross referencing. *)
 
-module Name = Odoc_name
 open Odoc_module
 open Odoc_class
 open Odoc_extension
@@ -58,24 +57,23 @@ module P_alias =
          Some (Module_type_alias _) -> true
        | _ -> false
       )
-    let p_class c _ = (false, false)
-    let p_class_type ct _ = (false, false)
-    let p_value v _ = false
+    let p_class _ _ = (false, false)
+    let p_class_type _ _ = (false, false)
+    let p_value _ _ = false
     let p_recfield _ _ _ = false
     let p_const _ _ _ = false
-    let p_type t _ = (false, false)
+    let p_type _ _ = (false, false)
     let p_extension x _ = x.xt_alias <> None
     let p_exception e _ = e.ex_alias <> None
-    let p_attribute a _ = false
-    let p_method m _ = false
-    let p_section s _ = false
+    let p_attribute _ _ = false
+    let p_method _ _ = false
+    let p_section _ _ = false
   end
 
 (** The module used to get the aliased elements. *)
 module Search_alias = Odoc_search.Search (P_alias)
 
 type alias_state =
-    Alias_resolved
   | Alias_to_resolve
 
 (** Couples of module name aliases. *)
@@ -140,36 +138,6 @@ let get_alias_names module_list =
   Hashtbl.clear exception_aliases;
   build_alias_list (Search_alias.search module_list 0)
 
-exception Found of string
-let name_alias =
-  let rec f t name =
-    try
-      match Hashtbl.find t name with
-        (s, Alias_resolved) -> s
-      | (s, Alias_to_resolve) -> f t s
-    with
-      Not_found ->
-        try
-          Hashtbl.iter
-            (fun n2 (n3, _) ->
-              if Name.prefix n2 name then
-                let ln2 = String.length n2 in
-                let s = n3^(String.sub name ln2 ((String.length name) - ln2)) in
-                raise (Found s)
-            )
-            t ;
-          Hashtbl.replace t name (name, Alias_resolved);
-          name
-        with
-          Found s ->
-            let s2 = f t s in
-            Hashtbl.replace t s2 (s2, Alias_resolved);
-            s2
-  in
-  fun name alias_tbl ->
-    f alias_tbl name
-
-
 module Map_ord =
   struct
     type t = string
@@ -188,7 +156,7 @@ let add_known_element name k =
     Not_found ->
       known_elements := Ele_map.add name [k] !known_elements
 
-let rec get_known_elements name =
+let get_known_elements name =
   try Ele_map.find name !known_elements
   with Not_found -> []
 
@@ -322,11 +290,9 @@ let init_known_elements_map module_list =
 
 (** The type to describe the names not found. *)
 type not_found_name =
-    NF_m of Name.t
   | NF_mt of Name.t
   | NF_mmt of Name.t
   | NF_c of Name.t
-  | NF_ct of Name.t
   | NF_cct of Name.t
   | NF_xt of Name.t
   | NF_ex of Name.t
@@ -392,7 +358,7 @@ let rec associate_in_module module_list (acc_b_modif, acc_incomplete_top_module_
      | Module_typeof _ ->
         (acc_b, acc_inc, acc_names)
 
-     | Module_unpack (code, mta) ->
+     | Module_unpack (_code, mta) ->
         begin
           match mta.mta_module with
             Some _ ->
@@ -608,8 +574,8 @@ and associate_in_class module_list (acc_b_modif, acc_incomplete_top_module_names
   in
   iter_kind (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) c.cl_kind
 
-and associate_in_class_type module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) ct =
-  let rec iter_kind (acc_b, acc_inc, acc_names) k =
+and associate_in_class_type _module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) ct =
+  let iter_kind (acc_b, acc_inc, acc_names) k =
     match k with
       Class_signature (inher_l, _) ->
         let f (acc_b2, acc_inc2, acc_names2) ic =
@@ -654,7 +620,7 @@ and associate_in_class_type module_list (acc_b_modif, acc_incomplete_top_module_
   in
   iter_kind (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) ct.clt_kind
 
-and associate_in_type_extension module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) te =
+and associate_in_type_extension _module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) te =
   List.fold_left
     (fun (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) xt ->
        match xt.xt_alias with
@@ -754,7 +720,7 @@ let rec assoc_comments_text_elements parent_name module_list t_ele =
                  | Odoc_search.Res_exception e -> (e.ex_name, RK_exception)
                  | Odoc_search.Res_attribute a -> (a.att_value.val_name, RK_attribute)
                  | Odoc_search.Res_method m -> (m.met_value.val_name, RK_method)
-                 | Odoc_search.Res_section (_ ,t)-> assert false
+                 | Odoc_search.Res_section _-> assert false
                  | Odoc_search.Res_recfield (t, f) ->
                      (Printf.sprintf "%s.%s" t.ty_name f.rf_name, RK_recfield)
                  | Odoc_search.Res_const (t, f) ->
@@ -791,7 +757,7 @@ let rec assoc_comments_text_elements parent_name module_list t_ele =
              match kind with
              | RK_section _ ->
                  (
-                  (** we just verify that we find an element of this kind with this name *)
+                  (* we just verify that we find an element of this kind with this name *)
                   try
                     let re = Str.regexp ("^"^(Str.quote name)^"$") in
                     let t = Odoc_search.find_section module_list re in
@@ -993,7 +959,7 @@ and assoc_comments_parameter parent_name module_list p =
   match p with
     Simple_name sn ->
       sn.sn_text <- ao (assoc_comments_text parent_name module_list) sn.sn_text
-  | Tuple (l, t) ->
+  | Tuple (l, _) ->
       List.iter (assoc_comments_parameter parent_name module_list) l
 
 and assoc_comments_parameter_list parent_name module_list pl =
@@ -1089,11 +1055,9 @@ let associate module_list =
            Odoc_global.pwarning
              (
               match nf with
-                NF_m n -> Odoc_messages.cross_module_not_found n
               | NF_mt n -> Odoc_messages.cross_module_type_not_found n
               | NF_mmt n -> Odoc_messages.cross_module_or_module_type_not_found n
               | NF_c n -> Odoc_messages.cross_class_not_found n
-              | NF_ct n -> Odoc_messages.cross_class_type_not_found n
               | NF_cct n -> Odoc_messages.cross_class_or_class_type_not_found n
               | NF_xt n -> Odoc_messages.cross_extension_not_found n
               | NF_ex n -> Odoc_messages.cross_exception_not_found n
diff --git a/ocamldoc/odoc_dag2html.ml b/ocamldoc/odoc_dag2html.ml
index 834aa595..c18c0568 100644
--- a/ocamldoc/odoc_dag2html.ml
+++ b/ocamldoc/odoc_dag2html.ml
@@ -32,9 +32,7 @@ and ghost_id
 ;;
 
 external span_id_of_int : int -> span_id = "%identity";;
-external int_of_span_id : span_id -> int = "%identity";;
 external ghost_id_of_int : int -> ghost_id = "%identity";;
-external int_of_ghost_id : ghost_id -> int = "%identity";;
 
 let new_span_id = let i = ref 0 in fun () -> incr i; span_id_of_int !i;;
 
@@ -44,7 +42,6 @@ let new_ghost_id = let i = ref 0 in fun () -> incr i; ghost_id_of_int !i;;
 
 type align = LeftA | CenterA | RightA;;
 type table_data = TDstring of string | TDhr of align;;
-type html_table = (int * align * table_data) array array;;
 
 let html_table_struct indi_txt phony d t =
   let phony =
@@ -315,7 +312,11 @@ let ancestors d =
 ;;
 
 let get_children d parents =
-  let rec merge_children children el =
+  (* XXXX merge_children used to be declared as a recursive function,
+     but it was not.  I've not idea if it a bug or not.  One should
+     either fix it (if this is a bug), or simplify the code otherwise. *)
+
+  let merge_children children el =
     List.fold_right
       (fun (x, _) children ->
          match x with
@@ -419,7 +420,7 @@ let treat_new_row d t =
   let i = Array.length t.table - 1 in
   let rec loop t i j =
     match get_block t i j with
-      Some (parents, max_parent_colspan, span) ->
+      Some (parents, max_parent_colspan, _span) ->
         let children = get_children d parents in
         let children =
           if children = [] then [{elem = Nothing; span = new_span_id ()}]
@@ -499,7 +500,7 @@ let treat_new_row d t =
   loop t i 0
 ;;
 
-let down_it t i k y =
+let down_it t i k =
   t.table.(Array.length t.table - 1).(k) <- t.table.(i).(k);
   for r = i to Array.length t.table - 2 do
     t.table.(r).(k) <- {elem = Ghost (new_ghost_id ()); span = new_span_id ()}
@@ -530,7 +531,7 @@ let equilibrate t =
                 if k = len then loop1 (i + 1)
                 else
                   match t.table.(i).(k).elem with
-                    Elem y when x = y -> down_it t i k y; loop 0
+                    Elem y when x = y -> down_it t i k; loop 0
                   | _ -> loop2 (k + 1)
               in
               loop2 0
@@ -764,7 +765,7 @@ let find_block_with_parents t i jj1 jj2 jj3 jj4 =
   loop i jj1 jj2 jj3 jj4
 ;;
 
-let push_to_right d t i j1 j2 =
+let push_to_right t i j1 j2 =
   let line = t.(i) in
   let rec loop j =
     if j = j2 then j - 1
@@ -806,7 +807,7 @@ let push_to_right d t i j1 j2 =
   loop (j1 + 1)
 ;;
 
-let push_to_left d t i j1 j2 =
+let push_to_left t i j1 j2 =
   let line = t.(i) in
   let rec loop j =
     if j = j1 then j + 1
@@ -848,7 +849,7 @@ let push_to_left d t i j1 j2 =
   loop (j2 - 1)
 ;;
 
-let fill_gap d t i j1 j2 =
+let fill_gap t i j1 j2 =
   let t1 =
     let t1 = Array.copy t.table in
     for i = 0 to Array.length t.table - 1 do
@@ -859,8 +860,8 @@ let fill_gap d t i j1 j2 =
     done;
     t1
   in
-  let j2 = push_to_left d t1 i j1 j2 in
-  let j1 = push_to_right d t1 i j1 j2 in
+  let j2 = push_to_left t1 i j1 j2 in
+  let j1 = push_to_right t1 i j1 j2 in
   if j1 = j2 - 1 then
     let line = t1.(i - 1) in
     let x = line.(j1).span in
@@ -877,7 +878,7 @@ let fill_gap d t i j1 j2 =
   else None
 ;;
 
-let treat_gaps d t =
+let treat_gaps t =
   let i = Array.length t.table - 1 in
   let rec loop t j =
     let line = t.table.(i) in
@@ -890,7 +891,7 @@ let treat_gaps d t =
             let rec loop1 t j1 =
               if j1 < 0 then loop t (j + 1)
               else if y = line.(j1).elem then
-                match fill_gap d t i j1 j with
+                match fill_gap t i j1 j with
                   Some (t, ok) -> if ok then loop t 2 else loop t (j + 1)
                 | None -> loop t (j + 1)
               else loop1 t (j1 - 1)
@@ -947,7 +948,7 @@ let tablify phony no_optim no_group d =
           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 t = if no_optim then t else treat_gaps t in
           group_span_last_row t;
           t
         end
@@ -957,7 +958,7 @@ let tablify phony no_optim no_group d =
   loop t
 ;;
 
-let fall d t =
+let fall t =
   for i = 1 to Array.length t.table - 1 do
     let line = t.table.(i) in
     let rec loop j =
@@ -1023,7 +1024,7 @@ let fall d t =
   done
 ;;
 
-let fall2_cool_right t i1 i2 i3 j1 j2 =
+let fall2_cool_right t i1 i2 _i3 j1 j2 =
   let span = t.table.(i2 - 1).(j1).span in
   for i = i2 - 1 downto 0 do
     for j = j1 to j2 - 1 do
@@ -1048,7 +1049,7 @@ let fall2_cool_right t i1 i2 i3 j1 j2 =
   loop j1
 ;;
 
-let fall2_cool_left t i1 i2 i3 j1 j2 =
+let fall2_cool_left t i1 i2 _i3 j1 j2 =
   let span = t.table.(i2 - 1).(j2).span in
   for i = i2 - 1 downto 0 do
     for j = j1 + 1 to j2 do
@@ -1097,7 +1098,7 @@ let do_fall2_right t i1 i2 j1 j2 =
         else
           let new_line =
             Array.init (Array.length t.table.(0))
-              (fun i -> {elem = Nothing; span = new_span_id ()})
+              (fun _ -> {elem = Nothing; span = new_span_id ()})
           in
           let t = {table = Array.append t.table [| new_line |]} in
           loop (cnt - 1) t
@@ -1132,7 +1133,7 @@ let do_fall2_left t i1 i2 j1 j2 =
         else
           let new_line =
             Array.init (Array.length t.table.(0))
-              (fun i -> {elem = Nothing; span = new_span_id ()})
+              (fun _ -> {elem = Nothing; span = new_span_id ()})
           in
           let t = {table = Array.append t.table [| new_line |]} in
           loop (cnt - 1) t
@@ -1447,7 +1448,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
-  fall () t;
+  fall t;
   let t = fall2_right t in
   let t = fall2_left t in
   let t = shorten_too_long t in
@@ -1455,148 +1456,8 @@ let table_of_dag phony no_optim invert no_group d =
 ;;
 
 
-let version = "1.01";;
-
 (* input dag *)
 
-let strip_spaces str =
-  let start =
-    let rec loop i =
-      if i == String.length str then i
-      else
-        match str.[i] with
-          ' ' | '\013' | '\n' | '\t' -> loop (i + 1)
-        | _ -> i
-    in
-    loop 0
-  in
-  let stop =
-    let rec loop i =
-      if i == -1 then i + 1
-      else
-        match str.[i] with
-          ' ' | '\013' | '\n' | '\t' -> loop (i - 1)
-        | _ -> i + 1
-    in
-    loop (String.length str - 1)
-  in
-  if start == 0 && stop == String.length str then str
-  else if start > stop then ""
-  else String.sub str start (stop - start)
-;;
-
-let rec get_line ic =
-  try
-    let line = input_line ic in
-    if String.length line > 0 && line.[0] = '#' then get_line ic
-    else Some (strip_spaces line)
-  with
-    End_of_file -> None
-;;
-
-let input_dag ic =
-  let rec find cnt s =
-    function
-      n :: nl ->
-        if n.valu = s then n, idag_of_int cnt else find (cnt - 1) s nl
-    | [] -> raise Not_found
-  in
-  let add_node pl cl nl cnt =
-    let cl = List.rev cl in
-    let pl = List.rev pl in
-    let (pl, pnl, nl, cnt) =
-      List.fold_left
-        (fun (pl, pnl, nl, cnt) p ->
-           try
-             let (n, p) = find (cnt - 1) p nl in p :: pl, n :: pnl, nl, cnt
-           with
-             Not_found ->
-               let n = {pare = []; valu = p; chil = []} in
-               let p = idag_of_int cnt in p :: pl, n :: pnl, n :: nl, cnt + 1)
-        ([], [], nl, cnt) pl
-    in
-    let pl = List.rev pl in
-    let (cl, nl, cnt) =
-      List.fold_left
-        (fun (cl, nl, cnt) c ->
-           try
-             let (n, c) = find (cnt - 1) c nl in
-             n.pare <- n.pare @ pl; c :: cl, nl, cnt
-           with
-             Not_found ->
-               let n = {pare = pl; valu = c; chil = []} in
-               let c = idag_of_int cnt in c :: cl, n :: nl, cnt + 1)
-        ([], nl, cnt) cl
-    in
-    let cl = List.rev cl in
-    List.iter (fun p -> p.chil <- p.chil @ cl) pnl; nl, cnt
-  in
-  let rec input_parents nl pl cnt =
-    function
-      Some "" -> input_parents nl pl cnt (get_line ic)
-    | Some line ->
-        begin match line.[0] with
-          'o' ->
-            let p =
-              strip_spaces (String.sub line 1 (String.length line - 1))
-            in
-            if p = "" then failwith line
-            else input_parents nl (p :: pl) cnt (get_line ic)
-        | '-' ->
-            if pl = [] then failwith line
-            else input_children nl pl [] cnt (Some line)
-        | _ -> failwith line
-        end
-    | None -> if pl = [] then nl, cnt else failwith "end of file 1"
-  and input_children nl pl cl cnt =
-    function
-      Some "" -> input_children nl pl cl cnt (get_line ic)
-    | Some line ->
-        begin match line.[0] with
-          'o' ->
-            if cl = [] then failwith line
-            else
-              let (nl, cnt) = add_node pl cl nl cnt in
-              input_parents nl [] cnt (Some line)
-        | '-' ->
-            let c =
-              strip_spaces (String.sub line 1 (String.length line - 1))
-            in
-            if c = "" then failwith line
-            else input_children nl pl (c :: cl) cnt (get_line ic)
-        | _ -> failwith line
-        end
-    | None ->
-        if cl = [] then failwith "end of file 2" else add_node pl cl nl cnt
-  in
-  let (nl, _) = input_parents [] [] 0 (get_line ic) in
-  {dag = Array.of_list (List.rev nl)}
-;;
-
-(* testing *)
-
-let map_dag f d =
-  let a =
-    Array.map (fun d -> {pare = d.pare; valu = f d.valu; chil = d.chil}) d.dag
-  in
-  {dag = a}
-;;
-
-let tag_dag d =
-  let c = ref 'A' in
-  map_dag
-    (fun v ->
-       let v = !c in
-       c :=
-         if !c = 'Z' then 'a'
-         else if !c = 'z' then '1'
-         else Char.chr (Char.code !c + 1);
-       String.make 1 v)
-    d
-;;
-
-(* *)
-
 let phony _ = false;;
 let indi_txt n = n.valu;;
 
@@ -1638,9 +1499,7 @@ let string_table border hts =
   Buffer.contents buf
 ;;
 
-let fname = ref "";;
 let invert = ref false;;
-let char = ref false;;
 let border = ref 0;;
 let no_optim = ref false;;
 let no_group = ref false;;
diff --git a/ocamldoc/odoc_env.ml b/ocamldoc/odoc_env.ml
index caa2999f..ffb1dd20 100644
--- a/ocamldoc/odoc_env.ml
+++ b/ocamldoc/odoc_env.ml
@@ -137,11 +137,11 @@ let full_module_or_module_type_name env n =
 let full_type_name env n =
   try
     let full = List.assoc n env.env_types in
-(**    print_string ("type "^n^" is "^full);
+(*    print_string ("type "^n^" is "^full);
     print_newline ();*)
     full
   with Not_found ->
-(**    print_string ("type "^n^" not found");
+(*    print_string ("type "^n^" not found");
     print_newline ();*)
     n
 
@@ -174,9 +174,6 @@ let full_class_or_class_type_name env n =
   try List.assoc n env.env_classes
   with Not_found -> full_class_type_name env n
 
-let print_env_types env =
-  List.iter (fun (s1,s2) -> Printf.printf "%s = %s\n" s1 s2) env.env_types
-
 let subst_type env t =
 (*
   print_string "Odoc_env.subst_type\n";
@@ -190,7 +187,7 @@ let subst_type env t =
       deja_vu := t :: !deja_vu;
       Btype.iter_type_expr iter t;
       match t.Types.desc with
-      | Types.Tconstr (p, [ty], a) when Path.same p Predef.path_option ->
+      | Types.Tconstr (p, [_], _) when Path.same p Predef.path_option ->
           ()
       | Types.Tconstr (p, l, a) ->
           let new_p =
@@ -239,7 +236,7 @@ let subst_class_type env t =
         let new_texp_list = List.map (subst_type env) texp_list in
         let new_ct = iter ct in
         Types.Cty_constr (new_p, new_texp_list, new_ct)
-    | Types.Cty_signature cs ->
+    | Types.Cty_signature _ ->
         (* we don't handle vals and methods *)
         t
     | Types.Cty_arrow (l, texp, ct) ->
diff --git a/ocamldoc/odoc_gen.ml b/ocamldoc/odoc_gen.ml
index 2ff122dd..8ea2c947 100644
--- a/ocamldoc/odoc_gen.ml
+++ b/ocamldoc/odoc_gen.ml
@@ -23,7 +23,7 @@ module type Base = sig
   end;;
 
 module Base_generator : Base = struct
-  class generator : doc_generator = object method generate l = () end
+  class generator : doc_generator = object method generate _ = () end
   end;;
 
 module type Base_functor = functor (G: Base) -> Base
diff --git a/ocamldoc/odoc_global.ml b/ocamldoc/odoc_global.ml
index 08f1c548..fa366eae 100644
--- a/ocamldoc/odoc_global.ml
+++ b/ocamldoc/odoc_global.ml
@@ -18,8 +18,6 @@
 (* Tell ocaml compiler not to generate files. *)
 let _ = Clflags.dont_write_files := true
 
-open Clflags
-
 type source_file =
     Impl_file of string
   | Intf_file of string
diff --git a/ocamldoc/odoc_global.mli b/ocamldoc/odoc_global.mli
index a3af6afe..c4c38096 100644
--- a/ocamldoc/odoc_global.mli
+++ b/ocamldoc/odoc_global.mli
@@ -62,6 +62,7 @@ val hidden_modules : string list ref
 
 (** The files to be analysed. *)
 val files : source_file list ref
+
 (** A counter for errors. *)
 val errors : int ref
 
diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml
index c666afe9..0fe22af1 100644
--- a/ocamldoc/odoc_html.ml
+++ b/ocamldoc/odoc_html.ml
@@ -18,7 +18,6 @@
 let print_DEBUG s = print_string s ; print_newline ()
 
 open Odoc_info
-open Parameter
 open Value
 open Type
 open Extension
@@ -107,6 +106,10 @@ module Naming =
     let recfield_target t f = target mark_type_elt
       (Printf.sprintf "%s.%s" (Name.simple t.ty_name) f.rf_name)
 
+    (** Return the link target for the given inline record field. *)
+    let inline_recfield_target t c f = target mark_type_elt
+      (Printf.sprintf "%s.%s.%s" t c f.rf_name)
+
     (** Return the link target for the given object field. *)
     let objfield_target t f = target mark_type_elt
       (Printf.sprintf "%s.%s" (Name.simple t.ty_name) f.of_name)
@@ -222,7 +225,7 @@ end)
 
 (** A class with a method to colorize a string which represents OCaml code. *)
 class ocaml_code =
-  object(self)
+  object
     method html_of_code b ?(with_pre=true) code =
       Odoc_ocamlhtml.html_of_code b ~with_pre: with_pre code
   end
@@ -300,7 +303,7 @@ class virtual text =
       | Odoc_info.Custom (s,t) -> self#html_of_custom_text b s t
       | Odoc_info.Target (target, code) -> self#html_of_Target b ~target ~code
 
-    method html_of_custom_text b s t = ()
+    method html_of_custom_text _ _ _ = ()
 
     method html_of_Target b ~target ~code =
       if String.lowercase_ascii target = "html" then bs b code else ()
@@ -433,7 +436,7 @@ class virtual text =
       bs b tag_c;
       bs b ">"
 
-    method html_of_Latex b _ = ()
+    method html_of_Latex _ _ = ()
       (* don't care about LaTeX stuff in HTML. *)
 
     method html_of_Link b s t =
@@ -778,11 +781,15 @@ class html =
 
     val mutable doctype =
       "\n"
-    method character_encoding () =
-      Printf.sprintf
+    method character_encoding b =
+      bp b
         "\n"
         !charset
 
+    method meta b =
+      self#character_encoding b;
+      bs b "\n"
+
     (** The default style options. *)
     val mutable default_style_options =
       [ ".keyword { font-weight : bold ; color : Red }" ;
@@ -898,22 +905,31 @@ class html =
 
     (** The file for the index of values. *)
     method index_values = Printf.sprintf "%s_values.html" self#index_prefix
+
     (** The file for the index of types. *)
     method index_types = Printf.sprintf "%s_types.html" self#index_prefix
+
     (** The file for the index of extensions. *)
     method index_extensions = Printf.sprintf "%s_extensions.html" self#index_prefix
+
     (** The file for the index of exceptions. *)
     method index_exceptions = Printf.sprintf "%s_exceptions.html" self#index_prefix
+
     (** The file for the index of attributes. *)
     method index_attributes = Printf.sprintf "%s_attributes.html" self#index_prefix
+
     (** The file for the index of methods. *)
     method index_methods = Printf.sprintf "%s_methods.html" self#index_prefix
+
     (** The file for the index of classes. *)
     method index_classes = Printf.sprintf "%s_classes.html" self#index_prefix
+
     (** The file for the index of class types. *)
     method index_class_types = Printf.sprintf "%s_class_types.html" self#index_prefix
+
     (** The file for the index of modules. *)
     method index_modules = Printf.sprintf "%s_modules.html" self#index_prefix
+
     (** The file for the index of module types. *)
     method index_module_types = Printf.sprintf "%s_module_types.html" self#index_prefix
 
@@ -921,36 +937,45 @@ class html =
     (** The list of attributes. Filled in the [generate] method. *)
     val mutable list_attributes = []
     method list_attributes = list_attributes
+
     (** The list of methods. Filled in the [generate] method. *)
     val mutable list_methods = []
     method list_methods = list_methods
+
     (** The list of values. Filled in the [generate] method. *)
     val mutable list_values = []
     method list_values = list_values
+
     (** The list of extensions. Filled in the [generate] method. *)
     val mutable list_extensions = []
     method list_extensions = list_extensions
+
     (** The list of exceptions. Filled in the [generate] method. *)
     val mutable list_exceptions = []
     method list_exceptions = list_exceptions
+
     (** The list of types. Filled in the [generate] method. *)
     val mutable list_types = []
     method list_types = list_types
+
     (** The list of modules. Filled in the [generate] method. *)
     val mutable list_modules = []
     method list_modules = list_modules
+
     (** The list of module types. Filled in the [generate] method. *)
     val mutable list_module_types = []
     method list_module_types = list_module_types
+
     (** The list of classes. Filled in the [generate] method. *)
     val mutable list_classes = []
     method list_classes = list_classes
+
     (** The list of class types. Filled in the [generate] method. *)
     val mutable list_class_types = []
     method list_class_types = list_class_types
 
     (** The header of pages. Must be prepared by the [prepare_header] method.*)
-    val mutable header = fun b -> fun ?(nav=None) -> fun ?(comments=[]) -> fun _ -> ()
+    val mutable header = fun _ -> fun ?nav:_ -> fun ?comments:_ -> fun _ -> ()
 
     (** Init the style. *)
     method init_style =
@@ -1002,7 +1027,7 @@ class html =
         in
         bs b "\n";
         bs b style;
-        bs b (self#character_encoding ()) ;
+        self#meta b;
         bs b "\n" ;
@@ -1133,14 +1158,14 @@ class html =
     method constructor s = ""^s^""
 
     (** Output the given ocaml code to the given file name. *)
-    method private output_code in_title file code =
+    method private output_code ?(with_pre=true) in_title file code =
       try
         let chanout = open_out file in
         let b = new_buf () in
         bs b "";
         self#print_header b (self#inner_title in_title);
         bs b"\n";
-        self#html_of_code b code;
+        self#html_of_code ~with_pre b code;
         bs b "";
         Buffer.output_buffer chanout b;
         close_out chanout
@@ -1208,21 +1233,23 @@ class html =
       bs b ""
 
     (** Print html code to display a [Types.type_expr list]. *)
-    method html_of_cstr_args ?par b m_name sep l =
+    method html_of_cstr_args ?par b m_name c_name sep l =
       print_DEBUG "html#html_of_cstr_args";
-      let s =
-        match l with
-        | Cstr_tuple l ->
-            Odoc_info.string_of_type_list ?par sep l
-        | Cstr_record l ->
-            Odoc_info.string_of_record l
-      in
-      print_DEBUG "html#html_of_cstr_args: 1";
-      let s2 = newline_to_indented_br s in
-      print_DEBUG "html#html_of_cstr_args: 2";
-      bs b "";
-      bs b (self#create_fully_qualified_idents_links m_name s2);
-      bs b ""
+      match l with
+      | Cstr_tuple l ->
+          print_DEBUG "html#html_of_cstr_args: 1";
+          let s = Odoc_info.string_of_type_list ?par sep l in
+          let s2 = newline_to_indented_br s in
+          print_DEBUG "html#html_of_cstr_args: 2";
+          bs b "";
+          bs b (self#create_fully_qualified_idents_links m_name s2);
+          bs b ""
+      | Cstr_record l ->
+          print_DEBUG "html#html_of_cstr_args: 1 bis";
+          bs b "";
+          self#html_of_record ~father:m_name ~close_env: ""
+            (Naming.inline_recfield_target m_name c_name)
+            b l
 
     (** Print html code to display a [Types.type_expr list] as type parameters
        of a class of class type. *)
@@ -1305,7 +1332,7 @@ class html =
           bs b " ";
           bs b (self#create_fully_qualified_module_idents_links father s);
           bs b ""
-      | Module_constraint (k, tk) ->
+      | Module_constraint (k, _tk) ->
           (* TODO: what to print ? *)
           self#html_of_module_kind b father ?modu k
       | Module_typeof s ->
@@ -1412,12 +1439,12 @@ class html =
     (** Generate a file containing the module type in the given file name. *)
     method output_module_type in_title file mtyp =
       let s = Odoc_info.remove_ending_newline (Odoc_info.string_of_module_type ~complete: true mtyp) in
-      self#output_code in_title file s
+      self#output_code ~with_pre:false in_title file s
 
     (** Generate a file containing the class type in the given file name. *)
     method output_class_type in_title file ctyp =
       let s = Odoc_info.remove_ending_newline (Odoc_info.string_of_class_type ~complete: true ctyp) in
-      self#output_code in_title file s
+      self#output_code ~with_pre:false in_title file s
 
     (** Print html code for a value. *)
     method html_of_value b v =
@@ -1464,6 +1491,7 @@ class html =
       bs b "\n";
       let print_one x =
         let father = Name.father x.xt_name in
+        let cname = Name.simple x.xt_name in
         bs b "\n
\n";
         bs b "";
         bs b (self#keyword "|");
@@ -1471,19 +1499,19 @@ class html =
         bs b "";
         bp b "%s"
           (Naming.extension_target x)
-          (Name.simple x.xt_name);
+          cname;
         (
           match x.xt_args, x.xt_ret with
               Cstr_tuple [], None -> ()
             | l,None ->
                 bs b (" " ^ (self#keyword "of") ^ " ");
-                self#html_of_cstr_args ~par: false b father " * " l;
+                self#html_of_cstr_args ~par: false b father cname " * " l;
             | Cstr_tuple [],Some r ->
                 bs b (" " ^ (self#keyword ":") ^ " ");
                 self#html_of_type_expr b father r;
             | l,Some r ->
                 bs b (" " ^ (self#keyword ":") ^ " ");
-                self#html_of_cstr_args ~par: false b father " * " l;
+                self#html_of_cstr_args ~par: false b father cname " * " l;
                 bs b (" " ^ (self#keyword "->") ^ " ");
                 self#html_of_type_expr b father r;
         );
@@ -1526,29 +1554,31 @@ class html =
 
     (** Print html code for an exception. *)
     method html_of_exception b e =
+      let cname = Name.simple e.ex_name in
       Odoc_info.reset_type_names ();
       bs b "\n
";
       bp b "" (Naming.exception_target e);
       bs b (self#keyword "exception");
       bs b " ";
-      bs b (Name.simple e.ex_name);
+      bs b cname;
       bs b "";
       (
+        let father = Name.father e.ex_name in
         match e.ex_args, e.ex_ret with
           Cstr_tuple [], None -> ()
-        | l,None ->
+        | _,None ->
             bs b (" "^(self#keyword "of")^" ");
             self#html_of_cstr_args
-                   ~par: false b (Name.father e.ex_name) " * " e.ex_args
+                   ~par:false b father cname " * " e.ex_args
         | Cstr_tuple [],Some r ->
             bs b (" " ^ (self#keyword ":") ^ " ");
-            self#html_of_type_expr b (Name.father e.ex_name) r;
+            self#html_of_type_expr b father r;
         | l,Some r ->
             bs b (" " ^ (self#keyword ":") ^ " ");
             self#html_of_cstr_args
-                   ~par: false b (Name.father e.ex_name) " * " l;
+                   ~par:false b father cname " * " l;
             bs b (" " ^ (self#keyword "->") ^ " ");
-            self#html_of_type_expr b (Name.father e.ex_name) r;
+            self#html_of_type_expr b father r;
       );
       (
        match e.ex_alias with
@@ -1565,6 +1595,38 @@ class html =
       bs b "
\n";
       self#html_of_info b e.ex_info
 
+    method html_of_record ~father ~close_env gen_name  b l =
+      bs b "{";
+      bs b close_env;
+      bs b "\n" ;
+      let print_one r =
+        bs b "\n\n\n";
+        (
+          match r.rf_text with
+            None -> ()
+          | Some t ->
+              bs b "";
+              bs b "";
+        );
+        bs b "\n"
+      in
+      print_concat b "\n" print_one l;
+      bs b "
\n";
+        bs b "  ";
+        bs b "\n";
+        bs b "";
+        if r.rf_mutable then bs b (self#keyword "mutable ") ;
+        bp b "%s : " (gen_name r) r.rf_name;
+        self#html_of_type_expr b father r.rf_type;
+        bs b ";";
+              bs b "";
+              bs b "(*";
+              bs b "";
+              self#html_of_info b (Some t);
+              bs b "";
+              bs b "*)
\n}\n"
+
+
     (** Print html code for a type. *)
     method html_of_type b t =
       Odoc_info.reset_type_names ();
@@ -1658,13 +1720,13 @@ class html =
                Cstr_tuple [], None -> ()
              | l,None ->
                  bs b (" " ^ (self#keyword "of") ^ " ");
-                 self#html_of_cstr_args ~par: false b father " * " l;
+                 self#html_of_cstr_args ~par:false b father constr.vc_name " * " l;
              | Cstr_tuple [],Some r ->
                  bs b (" " ^ (self#keyword ":") ^ " ");
                  self#html_of_type_expr b father r;
              | l,Some r ->
                  bs b (" " ^ (self#keyword ":") ^ " ");
-                 self#html_of_cstr_args ~par: false b father " * " l;
+                 self#html_of_cstr_args ~par: false b father constr.vc_name " * " l;
                  bs b (" " ^ (self#keyword "->") ^ " ");
                  self#html_of_type_expr b father r;
             );
@@ -1693,42 +1755,10 @@ class html =
       | Type_record l ->
           bs b "= ";
           if priv then bs b "private " ;
-          bs b "{";
-          bs b
-            (
-             match t.ty_manifest with
-               None -> ""
-             | Some _ -> ""
-            );
-          bs b "\n" ;
-          let print_one r =
-            bs b "\n\n\n";
-            (
-             match r.rf_text with
-               None -> ()
-             | Some t ->
-                 bs b "";
-                 bs b "";
-            );
-            bs b "\n"
-          in
-          print_concat b "\n" print_one l;
-          bs b "
\n";
-            bs b "  ";
-            bs b "\n";
-            bs b "";
-            if r.rf_mutable then bs b (self#keyword "mutable ") ;
-            bp b "%s : "
-              (Naming.recfield_target t r)
-              r.rf_name;
-            self#html_of_type_expr b father r.rf_type;
-            bs b ";";
-                 bs b "";
-                 bs b "(*";
-                 bs b "";
-                 self#html_of_info b (Some t);
-                 bs b "";
-                 bs b "*)
\n}\n"
+          let close_env = match t.ty_manifest with
+              None -> ""
+            | Some _ -> "" in
+          self#html_of_record ~father ~close_env (Naming.recfield_target t) b l
       | Type_open ->
           bs b "= ..";
           bs b ""
@@ -1860,7 +1890,7 @@ class html =
           bs b "
\n\n\n\n"
 
     (** Print html code for the parameters which have a name and description. *)
-    method html_of_described_parameter_list b m_name l =
+    method html_of_described_parameter_list b _m_name l =
       (* get the params which have a name, and at least one name described. *)
       let l2 = List.filter
           (fun p ->
@@ -2024,7 +2054,7 @@ class html =
           );
           self#html_of_text b [Code "end"]
 
-      | Class_apply capp ->
+      | Class_apply _ ->
           (* TODO: display final type from typedtree *)
           self#html_of_text b [Raw "class application not handled yet"]
 
@@ -2245,7 +2275,7 @@ class html =
             ()
         | Class_structure (l, _) ->
             self#generate_inheritance_info b l
-        | Class_constraint (k, ct) ->
+        | Class_constraint (k, _) ->
             iter_kind k
         | Class_apply _
         | Class_constr _ ->
@@ -2571,7 +2601,7 @@ class html =
         match modu.m_code with
           None -> ()
         | Some code ->
-            self#output_code
+            self#output_code ~with_pre:false
               modu.m_name
               (Filename.concat !Global.target_dir code_file)
               code
@@ -2605,7 +2635,7 @@ class html =
              bs b "
";
              self#html_of_Module_list b
                (List.map (fun m -> m.m_name) module_list);
-         | Some i -> self#html_of_info ~indent: false b info
+         | Some _ -> self#html_of_info ~indent: false b info
         );
         bs b "\n";
         Buffer.output_buffer chanout b;
@@ -2615,7 +2645,7 @@ class html =
           raise (Failure s)
 
     (** Generate the values index in the file [index_values.html]. *)
-    method generate_values_index module_list =
+    method generate_values_index _module_list =
       self#generate_elements_index
         self#list_values
         (fun v -> v.val_name)
@@ -2625,7 +2655,7 @@ class html =
         self#index_values
 
     (** Generate the extensions index in the file [index_extensions.html]. *)
-    method generate_extensions_index module_list =
+    method generate_extensions_index _module_list =
       self#generate_elements_index
         self#list_extensions
         (fun x -> x.xt_name)
@@ -2635,7 +2665,7 @@ class html =
         self#index_extensions
 
     (** Generate the exceptions index in the file [index_exceptions.html]. *)
-    method generate_exceptions_index module_list =
+    method generate_exceptions_index _module_list =
       self#generate_elements_index
         self#list_exceptions
         (fun e -> e.ex_name)
@@ -2645,7 +2675,7 @@ class html =
         self#index_exceptions
 
     (** Generate the types index in the file [index_types.html]. *)
-    method generate_types_index module_list =
+    method generate_types_index _module_list =
       self#generate_elements_index
         self#list_types
         (fun t -> t.ty_name)
@@ -2655,7 +2685,7 @@ class html =
         self#index_types
 
     (** Generate the attributes index in the file [index_attributes.html]. *)
-    method generate_attributes_index module_list =
+    method generate_attributes_index _module_list =
       self#generate_elements_index
         self#list_attributes
         (fun a -> a.att_value.val_name)
@@ -2665,7 +2695,7 @@ class html =
         self#index_attributes
 
     (** Generate the methods index in the file [index_methods.html]. *)
-    method generate_methods_index module_list =
+    method generate_methods_index _module_list =
       self#generate_elements_index
         self#list_methods
         (fun m -> m.met_value.val_name)
@@ -2675,7 +2705,7 @@ class html =
         self#index_methods
 
     (** Generate the classes index in the file [index_classes.html]. *)
-    method generate_classes_index module_list =
+    method generate_classes_index _module_list =
       self#generate_elements_index
         self#list_classes
         (fun c -> c.cl_name)
@@ -2685,7 +2715,7 @@ class html =
         self#index_classes
 
     (** Generate the class types index in the file [index_class_types.html]. *)
-    method generate_class_types_index module_list =
+    method generate_class_types_index _module_list =
       self#generate_elements_index
         self#list_class_types
         (fun ct -> ct.clt_name)
@@ -2695,7 +2725,7 @@ class html =
         self#index_class_types
 
     (** Generate the modules index in the file [index_modules.html]. *)
-    method generate_modules_index module_list =
+    method generate_modules_index _module_list =
       self#generate_elements_index
         self#list_modules
         (fun m -> m.m_name)
@@ -2705,7 +2735,7 @@ class html =
         self#index_modules
 
     (** Generate the module types index in the file [index_module_types.html]. *)
-    method generate_module_types_index module_list =
+    method generate_module_types_index _module_list =
       self#generate_elements_index
         self#list_module_types
         (fun mt -> mt.mt_name)
diff --git a/ocamldoc/odoc_info.mli b/ocamldoc/odoc_info.mli
index f0146472..d7c36777 100644
--- a/ocamldoc/odoc_info.mli
+++ b/ocamldoc/odoc_info.mli
@@ -136,6 +136,7 @@ module Name :
 module Parameter :
   sig
     (** {3 Types} *)
+
     (** Representation of a simple parameter name *)
     type simple_name = Odoc_parameter.simple_name =
         {
@@ -154,6 +155,7 @@ module Parameter :
     type parameter = param_info
 
     (** {3 Functions} *)
+
     (** Acces to the name as a string. For tuples, parenthesis and commas are added. *)
     val complete_name : parameter -> string
 
@@ -342,6 +344,7 @@ module Value :
 module Class :
   sig
     (** {3 Types} *)
+
     (** To keep the order of elements in a class. *)
     type class_element = Odoc_class.class_element =
         Class_attribute of Value.t_attribute
@@ -463,6 +466,7 @@ module Class :
 module Module :
   sig
     (** {3 Types} *)
+
     (** To keep the order of elements in a module. *)
     type module_element = Odoc_module.module_element =
         Element_module of t_module
@@ -914,7 +918,6 @@ module Scan :
   sig
     class scanner :
       object
-      (** Scan of 'leaf elements'. *)
 
         method scan_value : Value.t_value -> unit
 
diff --git a/ocamldoc/odoc_latex.ml b/ocamldoc/odoc_latex.ml
index 10a10ada..37252d63 100644
--- a/ocamldoc/odoc_latex.ml
+++ b/ocamldoc/odoc_latex.ml
@@ -18,7 +18,6 @@
 let print_DEBUG s = print_string s ; print_newline ()
 
 open Odoc_info
-open Parameter
 open Value
 open Type
 open Extension
@@ -69,6 +68,14 @@ let ps f s = Format.fprintf f "%s" s
 let bp = Printf.bprintf
 let bs = Buffer.add_string
 
+let rec merge_codepre = function
+    [] -> []
+  | [e] -> [e]
+  | (CodePre s1) :: (CodePre s2) :: q ->
+      merge_codepre ((CodePre (s1^"\n"^s2)) :: q)
+  | e :: q ->
+      e :: (merge_codepre q)
+
 let print_concat fmt sep f =
   let rec iter = function
       [] -> ()
@@ -293,7 +300,7 @@ class text =
       | Odoc_info.Custom (s,t) -> self#latex_of_custom_text fmt s t
       | Odoc_info.Target (target, code) -> self#latex_of_Target fmt ~target ~code
 
-    method latex_of_custom_text fmt s t = ()
+    method latex_of_custom_text _ _ _ = ()
 
     method latex_of_Target fmt ~target ~code =
       if String.lowercase_ascii target = "latex" then
@@ -519,7 +526,7 @@ class latex =
       match t.ty_parameters with
         [] -> ()
       | [(p,co,cn)] -> print_one (p, co, cn)
-      | l ->
+      | _ ->
           ps fmt "(";
           print_concat fmt ", " print_one t.ty_parameters;
           ps fmt ")"
@@ -528,11 +535,69 @@ class latex =
       self#latex_of_text fmt
         (self#text_of_class_params father c)
 
+
+    method entry_comment (fmt,flush) = function
+      | None -> []
+      | Some t ->
+          let s =
+            ps fmt "\\begin{ocamldoccomment}\n";
+            self#latex_of_info fmt (Some t);
+            ps fmt "\n\\end{ocamldoccomment}\n";
+            flush ()
+          in
+          [ Latex s]
+
+    (** record printing method *)
+    method latex_of_record ( (fmt,flush) as f) mod_name l =
+      p fmt "{";
+      let fields =
+        List.map (fun r ->
+            let s_field =
+              p fmt
+                "@[  %s%s :@ %s ;"
+                (if r.rf_mutable then "mutable " else "")
+                r.rf_name
+                (self#normal_type mod_name r.rf_type);
+              flush ()
+            in
+            [ CodePre s_field ] @ (self#entry_comment f r.rf_text)
+          ) l in
+      List.flatten fields @ [ CodePre "}" ]
+
+    method latex_of_cstr_args ( (fmt,flush) as f) mod_name (args, ret) =
+      match args, ret with
+      | Cstr_tuple [], None -> []
+      | Cstr_tuple _ as l, None ->
+          p fmt " of@ %s"
+            (self#normal_cstr_args ~par:false mod_name l);
+          [CodePre (flush())]
+      | Cstr_tuple _ as l, Some r ->
+          p fmt " :@ %s@ %s@ %s"
+            (self#normal_cstr_args ~par:false mod_name l)
+            "->"
+            (self#normal_type mod_name r);
+          [CodePre (flush())]
+      | Cstr_record l, None ->
+          p fmt " of@ ";
+          self#latex_of_record f mod_name l
+      | Cstr_record r, Some res ->
+          let l =
+            p fmt " :@ ";
+            self#latex_of_record f mod_name r in
+          let l2 =
+            p fmt "@ %s@ %s" "->"
+              (self#normal_type mod_name res);
+            [CodePre (flush())] in
+          l @ l2
+
+
+
+
     (** Print LaTeX code for a type. *)
     method latex_of_type fmt t =
       let s_name = Name.simple t.ty_name in
       let text =
-        let (fmt2, flush2) = new_fmt () in
+        let ( (fmt2, flush2) as f) = new_fmt () in
         Odoc_info.reset_type_names () ;
         let mod_name = Name.father t.ty_name in
         Format.fprintf fmt2 "@[type ";
@@ -558,24 +623,13 @@ class latex =
                 | _ -> ""
                 end
              | Type_variant _ -> "="^(if priv then " private" else "")
-             | Type_record _ -> "= "^(if priv then "private " else "")^"{"
+             | Type_record _ -> "= "^(if priv then "private " else "")
              | Type_open -> "= .."
             ) ;
           flush2 ()
         in
 
         let defs =
-          let entry_comment = function
-          | None -> []
-          | Some t ->
-              let s =
-                ps fmt2 "\\begin{ocamldoccomment}\n";
-                self#latex_of_info fmt2 (Some t);
-                ps fmt2 "\n\\end{ocamldoccomment}\n";
-                flush2 ()
-              in
-              [ Latex s]
-        in
           match t.ty_kind with
           | Type_abstract ->
              begin match t.ty_manifest with
@@ -589,7 +643,7 @@ class latex =
                        (self#normal_type mod_name r.of_type);
                      flush2 ()
                    in
-                   [ CodePre s_field ] @ (entry_comment r.of_text)
+                   [ CodePre s_field ] @ (self#entry_comment f r.of_text)
                  ) l
                in
                List.flatten fields @ [ CodePre ">" ]
@@ -598,58 +652,20 @@ class latex =
              end
           | Type_variant l ->
              let constructors =
-               List.map (fun constr ->
-                 let s_cons =
-                   p fmt2 "@[  | %s" constr.vc_name ;
-                   begin match constr.vc_args, constr.vc_ret with
-                   | Cstr_tuple [], None -> ()
-                   | l, None ->
-                     p fmt2 " of@ %s"
-                       (self#normal_cstr_args ~par: false mod_name l)
-                   | Cstr_tuple [], Some r ->
-                     p fmt2 " :@ %s"
-                       (self#normal_type mod_name r)
-                   | l, Some r ->
-                     p fmt2 " :@ %s@ %s@ %s"
-                       (self#normal_cstr_args ~par: false mod_name l)
-                       "->"
-                       (self#normal_type mod_name r)
-                   end ;
-                   flush2 ()
-                 in
-                 [ CodePre s_cons ] @ (entry_comment constr.vc_text)
-               ) l
+               List.map (fun {vc_name; vc_args; vc_ret; vc_text} ->
+                   p fmt2 "@[  | %s" vc_name ;
+                   let l = self#latex_of_cstr_args f mod_name (vc_args,vc_ret) in
+                   l @ (self#entry_comment f vc_text) ) l
              in
              List.flatten constructors
           | Type_record l ->
-             let fields =
-               List.map (fun r ->
-                 let s_field =
-                   p fmt2
-                     "@[  %s%s :@ %s ;"
-                     (if r.rf_mutable then "mutable " else "")
-                     r.rf_name
-                     (self#normal_type mod_name r.rf_type);
-                   flush2 ()
-                 in
-                 [ CodePre s_field ] @ (entry_comment r.rf_text)
-               ) l
-             in
-             List.flatten fields @ [ CodePre "}" ]
+              self#latex_of_record f mod_name l
           | Type_open ->
              (* FIXME ? *)
              []
         in
         let defs2 = (CodePre s_type3) :: defs in
-        let rec iter = function
-            [] -> []
-          | [e] -> [e]
-          | (CodePre s1) :: (CodePre s2) :: q ->
-              iter ((CodePre (s1^"\n"^s2)) :: q)
-          | e :: q ->
-              e :: (iter q)
-        in
-        (iter defs2) @
+        (merge_codepre defs2) @
         [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @
         (self#text_of_info t.ty_info)
       in
@@ -659,7 +675,7 @@ class latex =
     (** Print LaTeX code for a type extension. *)
     method latex_of_type_extension mod_name fmt te =
       let text =
-        let (fmt2, flush2) = new_fmt () in
+        let (fmt2, flush2) as f = new_fmt () in
         Odoc_info.reset_type_names () ;
         Format.fprintf fmt2 "@[type ";
         (
@@ -681,42 +697,22 @@ class latex =
              (List.map
                 (fun x ->
                    let father = Name.father x.xt_name in
-                   let s_cons =
-                     p fmt2 "@[  | %s" (Name.simple x.xt_name);
-                     (
-                       match x.xt_args, x.xt_ret with
-                           Cstr_tuple [], None -> ()
-                         | l, None ->
-                             p fmt2 " %s@ %s"
-                               "of"
-                               (self#normal_cstr_args ~par: false father l)
-                         | Cstr_tuple [], Some r ->
-                             p fmt2 " %s@ %s"
-                               ":"
-                               (self#normal_type father r)
-                         | l, Some r ->
-                             p fmt2 " %s@ %s@ %s@ %s"
-                               ":"
-                               (self#normal_cstr_args ~par: false father l)
-                               "->"
-                               (self#normal_type father r)
-                     );
-                     (
-                       match x.xt_alias with
-                           None -> ()
-                         | Some xa ->
-                             p fmt2 " = %s"
-                               (
-                                 match xa.xa_xt with
-                                     None -> xa.xa_name
-                                   | Some x -> x.xt_name
-                               )
-                     );
-                     flush2 ()
-                    in
-                    [ Latex (self#make_label (self#extension_label x.xt_name));
-                      CodePre s_cons ] @
-                    (match x.xt_text with
+                   p fmt2 "@[  | %s" (Name.simple x.xt_name);
+                   let l = self#latex_of_cstr_args f father (x.xt_args, x.xt_ret) in
+                   let c =
+                     begin match x.xt_alias with
+                     | None -> ()
+                     | Some xa ->
+                         p fmt2 " = %s"
+                           (
+                             match xa.xa_xt with
+                             | None -> xa.xa_name
+                             | Some x -> x.xt_name
+                           )
+                     end;
+                       [CodePre (flush2 ())] in
+                    Latex (self#make_label (self#extension_label x.xt_name)) :: l @ c
+                    @ (match x.xt_text with
                       None -> []
                     | Some t ->
                         let s =
@@ -733,25 +729,35 @@ class latex =
               )
         in
         let defs2 = (CodePre s_type3) :: defs in
-        let rec iter = function
-            [] -> []
-          | [e] -> [e]
-          | (CodePre s1) :: (CodePre s2) :: q ->
-              iter ((CodePre (s1^"\n"^s2)) :: q)
-          | e :: q ->
-              e :: (iter q)
-        in
-        (iter defs2) @
+        (merge_codepre defs2) @
         (self#text_of_info te.te_info)
       in
       self#latex_of_text fmt text
 
     (** Print LaTeX code for an exception. *)
     method latex_of_exception fmt e =
-      Odoc_info.reset_type_names () ;
-      self#latex_of_text fmt
-        ((Latex (self#make_label (self#exception_label e.ex_name))) ::
-         (to_text#text_of_exception e))
+      let text =
+        let (fmt2, flush2) as f = new_fmt() in
+        Odoc_info.reset_type_names () ;
+        let s_name = Name.simple e.ex_name in
+        let father = Name.father e.ex_name in
+        p fmt2 "@[exception %s" s_name;
+        let l = self#latex_of_cstr_args f father (e.ex_args, e.ex_ret) in
+        let s =
+          (match e.ex_alias with
+             None -> ()
+           | Some ea ->
+               Format.fprintf fmt " = %s"
+                 (
+                   match ea.ea_ex with
+                     None -> ea.ea_name
+                   | Some e -> e.ex_name
+                 )
+          ); [CodePre (flush2 ())] in
+       merge_codepre (l @ s ) @
+      [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")]
+       @ (self#text_of_info e.ex_info) in
+      self#latex_of_text fmt text
 
     method latex_of_module_parameter fmt m_name p =
       self#latex_of_text fmt
@@ -814,7 +820,7 @@ class latex =
             [ Code " ";
               Code (self#relative_idents father s) ;
             ]
-      | Module_constraint (k, tk) ->
+      | Module_constraint (k, _tk) ->
           (* TODO: what should we print? *)
           self#latex_of_module_kind fmt father k
       | Module_typeof s ->
@@ -836,7 +842,7 @@ class latex =
           List.iter (self#latex_of_class_element fmt father) eles;
           self#latex_of_text fmt [Latex "\\end{ocamldocobjectend}\n"]
 
-      | Class_apply capp ->
+      | Class_apply _ ->
           (* TODO: print final type from typedtree *)
           self#latex_of_text fmt [Raw "class application not handled yet"]
 
@@ -990,7 +996,7 @@ class latex =
       self#latex_of_text fmt t;
       (
        match mt.mt_type, mt.mt_kind with
-       | Some mtyp, Some kind ->
+       | Some _, Some kind ->
            self#latex_of_text fmt [ Code " = " ];
            self#latex_of_text fmt [ Latex "\\end{ocamldoccode}\n" ];
            self#latex_for_module_type_label fmt mt;
diff --git a/ocamldoc/odoc_man.ml b/ocamldoc/odoc_man.ml
index 79ee5b17..a640d767 100644
--- a/ocamldoc/odoc_man.ml
+++ b/ocamldoc/odoc_man.ml
@@ -15,7 +15,6 @@
 
 (** The man pages generator. *)
 open Odoc_info
-open Parameter
 open Value
 open Type
 open Extension
@@ -195,7 +194,7 @@ class virtual info =
         [] l
 
     (** Print the groff string to display an optional info structure. *)
-    method man_of_info ?(margin=0) b info_opt =
+    method man_of_info ?margin:(_ :int option) b info_opt =
         match info_opt with
         None -> ()
       | Some info ->
@@ -319,12 +318,12 @@ class man =
           bs b "\n.sp\n";
           self#man_of_text2 b t;
           bs b "\n.sp\n"
-      | Odoc_info.Title (n, l_opt, t) ->
+      | Odoc_info.Title (_, _, t) ->
           self#man_of_text2 b [Odoc_info.Code (Odoc_info.string_of_text t)]
       | Odoc_info.Latex _ ->
           (* don't care about LaTeX stuff in HTML. *)
           ()
-      | Odoc_info.Link (s, t) ->
+      | Odoc_info.Link (_, t) ->
           self#man_of_text2 b t
       | Odoc_info.Ref (name, _, _) ->
           self#man_of_text_element b
@@ -340,7 +339,7 @@ class man =
       | Odoc_info.Custom (s,t) -> self#man_of_custom_text b s t
       | Odoc_info.Target (target, code) -> self#man_of_Target b ~target ~code
 
-    method man_of_custom_text b s t = ()
+    method man_of_custom_text _ _ _ = ()
 
     method man_of_Target b ~target ~code =
       if String.lowercase_ascii target = "man" then bs b code else ()
@@ -385,23 +384,21 @@ class man =
 
     (** Print groff string to display a [Types.type_expr list].*)
     method man_of_cstr_args ?par b m_name sep l =
-      let s =
         match l with
         | Cstr_tuple l ->
-            Odoc_str.string_of_type_list ?par sep l
+            let s = Odoc_str.string_of_type_list ?par sep l in
+            let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in
+            bs b "\n.B ";
+            bs b (self#relative_idents m_name s2);
+            bs b "\n"
         | Cstr_record l ->
-            Odoc_str.string_of_record l
-      in
-      let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in
-      bs b "\n.B ";
-      bs b (self#relative_idents m_name s2);
-      bs b "\n"
+            self#man_of_record m_name b l
 
     (** Print groff string to display the parameters of a type.*)
     method man_of_type_expr_param_list b m_name t =
       match t.ty_parameters with
         [] -> ()
-      | l ->
+      | _ ->
           let s = Odoc_str.string_of_type_param_list t in
           let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in
           bs b "\n.B ";
@@ -436,7 +433,7 @@ class man =
       (
         match te.te_type_parameters with
             [] -> ()
-          | l ->
+          | _ ->
               let s = Odoc_str.string_of_type_extension_param_list te in
               let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in
                 bs b "\n.B ";
@@ -506,7 +503,7 @@ class man =
       (
         match e.ex_args, e.ex_ret with
         | Cstr_tuple [], None -> ()
-        | l, None ->
+        | _, None ->
            bs b ".B of ";
            self#man_of_cstr_args
              ~par: false
@@ -538,17 +535,31 @@ class man =
       self#man_of_info b e.ex_info;
       bs b "\n.sp\n"
 
+
+    method field_comment b = function
+      | None -> ()
+      | Some t ->
+          bs b "  (* ";
+          self#man_of_info b (Some t);
+          bs b " *) "
+
+    (** Print groff string for a record type *)
+    method man_of_record father b l =
+          bs b "{";
+           List.iter (fun r ->
+             bs b (if r.rf_mutable then "\n\n.B mutable \n" else "\n ");
+             bs b (r.rf_name^" : ");
+             self#man_of_type_expr b father r.rf_type;
+             bs b ";";
+             self#field_comment b r.rf_text ;
+           ) l;
+          bs b "\n }\n"
+
+
     (** Print groff string for a type. *)
     method man_of_type b t =
       Odoc_info.reset_type_names () ;
       let father = Name.father t.ty_name in
-      let field_comment = function
-        | None -> ()
-        | Some t ->
-          bs b "  (* ";
-          self#man_of_info b (Some t);
-          bs b " *) "
-      in
       bs b ".I type ";
       self#man_of_type_expr_param_list b father t;
       (
@@ -570,7 +581,7 @@ class man =
             bs b (r.of_name^" : ");
             self#man_of_type_expr b father r.of_type;
             bs b ";";
-            field_comment r.of_text ;
+            self#field_comment b r.of_text ;
           ) l;
           bs b "\n >\n"
        | Some (Other typ) ->
@@ -632,15 +643,7 @@ class man =
       | Type_record l ->
           bs b "= ";
           if priv then bs b "private ";
-          bs b "{";
-           List.iter (fun r ->
-             bs b (if r.rf_mutable then "\n\n.B mutable \n" else "\n ");
-             bs b (r.rf_name^" : ");
-             self#man_of_type_expr b father r.rf_type;
-             bs b ";";
-             field_comment r.rf_text ;
-           ) l;
-          bs b "\n }\n"
+          self#man_of_record father b l
       | Type_open ->
           bs b "= ..";
           bs b "\n"
@@ -838,7 +841,7 @@ class man =
               bs b " * ";
               self#man_of_type_expr b modname ty)
             q
-       | Cstr_record _ -> bs b "{ ... }"
+       | Cstr_record r -> self#man_of_record c.vc_name b r
       );
       bs b "\n.sp\n";
       self#man_of_info b c.vc_text;
@@ -1170,7 +1173,7 @@ class man =
         | h :: q ->
             match acc2 with
               [] -> f acc1 [h] q
-            | h2 :: q2 ->
+            | h2 :: _ ->
                 if (name h) = (name h2) then
                   if List.mem h acc2 then
                     f acc1 acc2 q
diff --git a/ocamldoc/odoc_merge.ml b/ocamldoc/odoc_merge.ml
index 9a981e00..4f1bbff7 100644
--- a/ocamldoc/odoc_merge.ml
+++ b/ocamldoc/odoc_merge.ml
@@ -16,8 +16,6 @@
 (** Merge of information from [.ml] and [.mli] for a module.*)
 
 open Odoc_types
-
-module Name = Odoc_name
 open Odoc_parameter
 open Odoc_value
 open Odoc_type
@@ -113,7 +111,7 @@ let merge_info merge_options (m1 : info) (m2 : info) =
       [], [] -> []
     | l, []
     | [], l -> l
-    | l1, l2 ->
+    | l1, _ ->
         if List.mem Merge_before merge_options then
           merge_before_tags (m1.i_before @ m2.i_before)
         else
diff --git a/ocamldoc/odoc_misc.ml b/ocamldoc/odoc_misc.ml
index a95c2a9f..cffffffd 100644
--- a/ocamldoc/odoc_misc.ml
+++ b/ocamldoc/odoc_misc.ml
@@ -68,7 +68,7 @@ let list_concat sep =
   let rec iter = function
       [] -> []
     | [h] -> [h]
-    | h :: q -> h :: sep :: q
+    | h :: q -> h :: sep :: iter q
   in
   iter
 
@@ -126,7 +126,7 @@ let rec string_of_text t =
       | Odoc_types.Latex s -> "{% "^s^" %}"
       | Odoc_types.Link (s, t) ->
           "["^s^"]"^(string_of_text t)
-      | Odoc_types.Ref (name, _, Some text) ->
+      | Odoc_types.Ref (_name, _, Some text) ->
           Printf.sprintf "[%s]" (string_of_text text)
       | Odoc_types.Ref (name, _, None) ->
           iter (Odoc_types.Code name)
@@ -258,7 +258,7 @@ let rec text_list_concat sep l =
       t @ (sep :: (text_list_concat sep q))
 
 let rec text_no_title_no_list t =
-  let rec iter t_ele =
+  let iter t_ele =
     match t_ele with
     | Odoc_types.Title (_,_,t) -> text_no_title_no_list t
     | Odoc_types.List l
@@ -316,7 +316,7 @@ let get_titles_in_text t =
     | Odoc_types.Left t
     | Odoc_types.Right t
     | Odoc_types.Emphasize t -> iter_text t
-    | Odoc_types.Latex s -> ()
+    | Odoc_types.Latex _ -> ()
     | Odoc_types.Link (_, t)
     | Odoc_types.Superscript t
     | Odoc_types.Subscript t  -> iter_text t
diff --git a/ocamldoc/odoc_module.ml b/ocamldoc/odoc_module.ml
index 5c8cafbc..f986a4fd 100644
--- a/ocamldoc/odoc_module.ml
+++ b/ocamldoc/odoc_module.ml
@@ -246,7 +246,7 @@ let rec module_elements ?(trans=true) m =
             mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ;
             mt_loc = Odoc_types.dummy_loc ;
           }
-    | Module_constraint (k, tk) ->
+    | Module_constraint (k, _tk) ->
         print_DEBUG "Odoc_module.module_element: Module_constraint";
       (* FIXME : use k or tk ? *)
         module_elements ~trans: trans
@@ -416,7 +416,7 @@ and module_parameters ?(trans=true) m =
           | Some (Modtype mt) -> module_type_parameters ~trans mt
         else
           []
-    | Module_constraint (k, tk) ->
+    | Module_constraint (_k, tk) ->
         module_type_parameters ~trans: trans
           { mt_name = "" ; mt_info = None ; mt_type = None ;
             mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ;
diff --git a/ocamldoc/odoc_name.ml b/ocamldoc/odoc_name.ml
index f6d5b7e4..df8a7860 100644
--- a/ocamldoc/odoc_name.ml
+++ b/ocamldoc/odoc_name.ml
@@ -146,7 +146,6 @@ let head_and_tail n =
     Not_found -> (n, "")
 
 let head n = fst (head_and_tail n)
-let tail n = snd (head_and_tail n)
 
 let depth name =
   try
diff --git a/ocamldoc/odoc_ocamlhtml.mll b/ocamldoc/odoc_ocamlhtml.mll
index 56b94afd..76debf1e 100644
--- a/ocamldoc/odoc_ocamlhtml.mll
+++ b/ocamldoc/odoc_ocamlhtml.mll
@@ -38,22 +38,30 @@ let base_escape_strings = [
     (">", ">") ;
 ]
 
-let pre_escape_strings = [
+
+let prelike_escape_strings = [
   (" ", " ") ;
   ("\t", "        ") ;
-  ]
+  ("\n", "
\n")
+]
 
 
 let pre = ref false
 let fmt = ref Format.str_formatter
 
 (** Escape the strings which would clash with html syntax,
-   and some other strings if we want to get a PRE style.*)
+   and some other strings if we want to get a PRE style outside of
+   
 
.*)
 let escape s =
+  let escape_strings =
+    if !pre then
+      base_escape_strings
+    else
+      base_escape_strings @ prelike_escape_strings in
   List.fold_left
     (fun acc -> fun (s, s2) -> Str.global_replace (Str.regexp s) s2 acc)
     s
-    (if !pre then base_escape_strings @ pre_escape_strings else base_escape_strings)
+    escape_strings
 
 (** Escape the strings which would clash with html syntax. *)
 let escape_base s =
@@ -82,7 +90,7 @@ let create_hashtable size init =
 
 (** The function used to return html code for the given comment body. *)
 let html_of_comment = ref
-    (fun (s : string) -> "Odoc_ocamlhtml.html_of_comment not initialized")
+    (fun (_ : string) -> "Odoc_ocamlhtml.html_of_comment not initialized")
 
 let keyword_table =
   create_hashtable 149 [
@@ -423,7 +431,7 @@ and comment = parse
   | "*)"
       { match !comment_start_pos with
         | [] -> assert false
-        | [x] -> comment_start_pos := []
+        | [_] -> comment_start_pos := []
         | _ :: l ->
             store_comment_char '*';
             store_comment_char ')';
diff --git a/ocamldoc/odoc_parser.mly b/ocamldoc/odoc_parser.mly
index faa98c87..9c762b1d 100644
--- a/ocamldoc/odoc_parser.mly
+++ b/ocamldoc/odoc_parser.mly
@@ -14,7 +14,6 @@
 (*                                                                        *)
 (**************************************************************************)
 
-open Odoc_types
 open Odoc_comments_global
 
 let uppercase = "[A-Z\192-\214\216-\222]"
diff --git a/ocamldoc/odoc_print.ml b/ocamldoc/odoc_print.ml
index 4ff1b29a..c07e7841 100644
--- a/ocamldoc/odoc_print.ml
+++ b/ocamldoc/odoc_print.ml
@@ -53,8 +53,8 @@ exception Use_code of string
 let simpl_module_type ?code t =
   let rec iter t =
     match t with
-      Types.Mty_ident p -> t
-    | Types.Mty_alias p -> t
+      Types.Mty_ident _
+    | Types.Mty_alias(_, _) -> t
     | Types.Mty_signature _ ->
         (
          match code with
@@ -79,7 +79,7 @@ let string_of_module_type ?code ?(complete=false) t =
 let simpl_class_type t =
   let rec iter t =
     match t with
-      Types.Cty_constr (p,texp_list,ct) -> t
+      Types.Cty_constr _ -> t
     | Types.Cty_signature cs ->
         (* we delete vals and methods in order to not print them when
            displaying the type *)
diff --git a/ocamldoc/odoc_scan.ml b/ocamldoc/odoc_scan.ml
index 0975cdf1..7b5ba5dd 100644
--- a/ocamldoc/odoc_scan.ml
+++ b/ocamldoc/odoc_scan.ml
@@ -27,14 +27,13 @@ open Odoc_types
    overriding some methods.*)
 class scanner =
   object (self)
-  (** Scan of 'leaf elements'. *)
 
-    method scan_value (v : Odoc_value.t_value) = ()
+    method scan_value (_ : Odoc_value.t_value) = ()
 
-    method scan_type_pre (t : Odoc_type.t_type) = true
+    method scan_type_pre (_ : Odoc_type.t_type) = true
 
-    method scan_type_recfield t (f : Odoc_type.record_field) = ()
-    method scan_type_const t (f : Odoc_type.variant_constructor) = ()
+    method scan_type_recfield _t (_ : Odoc_type.record_field) = ()
+    method scan_type_const _t (_ : Odoc_type.variant_constructor) = ()
     method scan_type (t : Odoc_type.t_type) =
       if self#scan_type_pre t then
         match t.Odoc_type.ty_kind with
@@ -43,11 +42,11 @@ class scanner =
         | Odoc_type.Type_record l -> List.iter (self#scan_type_recfield t) l
         | Odoc_type.Type_open -> ()
 
-    method scan_extension_constructor (e : Odoc_extension.t_extension_constructor) = ()
-    method scan_exception (e : Odoc_exception.t_exception) = ()
-    method scan_attribute (a : Odoc_value.t_attribute) = ()
-    method scan_method (m : Odoc_value.t_method) = ()
-    method scan_included_module (im : Odoc_module.included_module) = ()
+    method scan_extension_constructor (_ : Odoc_extension.t_extension_constructor) = ()
+    method scan_exception (_ : Odoc_exception.t_exception) = ()
+    method scan_attribute (_ : Odoc_value.t_attribute) = ()
+    method scan_method (_ : Odoc_value.t_method) = ()
+    method scan_included_module (_ : Odoc_module.included_module) = ()
 
   (** Scan of a type extension *)
 
@@ -55,7 +54,7 @@ class scanner =
         private and info. This method is called before scanning the
         extensions's constructors.
         @return true if the extension's constructors must be scanned.*)
-    method scan_type_extension_pre (x: Odoc_extension.t_type_extension) = true
+    method scan_type_extension_pre (_: Odoc_extension.t_type_extension) = true
 
     (** This method scans the constructors of the given type extension. *)
     method scan_type_extension_constructors (x: Odoc_extension.t_type_extension) =
@@ -70,12 +69,12 @@ class scanner =
   (** Scan of a class. *)
 
     (** Scan of a comment inside a class. *)
-    method scan_class_comment (t : text) = ()
+    method scan_class_comment (_ : text) = ()
 
     (** Override this method to perform controls on the class comment
        and params. This method is called before scanning the class elements.
        @return true if the class elements must be scanned.*)
-    method scan_class_pre (c : Odoc_class.t_class) = true
+    method scan_class_pre (_ : Odoc_class.t_class) = true
 
     (** This method scan the elements of the given class.
        A VOIR : scan des classes heritees.*)
@@ -96,12 +95,12 @@ class scanner =
   (** Scan of a class type. *)
 
     (** Scan of a comment inside a class type. *)
-    method scan_class_type_comment (t : text) = ()
+    method scan_class_type_comment (_ : text) = ()
 
     (** Override this method to perform controls on the class type comment
        and form. This method is called before scanning the class type elements.
        @return true if the class type elements must be scanned.*)
-    method scan_class_type_pre (ct : Odoc_class.t_class_type) = true
+    method scan_class_type_pre (_ : Odoc_class.t_class_type) = true
 
     (** This method scan the elements of the given class type.
        A VOIR : scan des classes heritees.*)
@@ -122,12 +121,12 @@ class scanner =
   (** Scan of modules. *)
 
     (** Scan of a comment inside a module. *)
-    method scan_module_comment (t : text) = ()
+    method scan_module_comment (_ : text) = ()
 
     (** Override this method to perform controls on the module comment
        and form. This method is called before scanning the module elements.
        @return true if the module elements must be scanned.*)
-    method scan_module_pre (m : Odoc_module.t_module) = true
+    method scan_module_pre (_ : Odoc_module.t_module) = true
 
     (** This method scan the elements of the given module. *)
     method scan_module_elements m =
@@ -154,12 +153,12 @@ class scanner =
   (** Scan of module types. *)
 
     (** Scan of a comment inside a module type. *)
-    method scan_module_type_comment (t : text) = ()
+    method scan_module_type_comment (_ : text) = ()
 
     (** Override this method to perform controls on the module type comment
        and form. This method is called before scanning the module type elements.
        @return true if the module type elements must be scanned. *)
-    method scan_module_type_pre (mt : Odoc_module.t_module_type) = true
+    method scan_module_type_pre (_ : Odoc_module.t_module_type) = true
 
     (** This method scan the elements of the given module type. *)
     method scan_module_type_elements mt =
diff --git a/ocamldoc/odoc_search.ml b/ocamldoc/odoc_search.ml
index 93dcbafe..530000bc 100644
--- a/ocamldoc/odoc_search.ml
+++ b/ocamldoc/odoc_search.ml
@@ -15,8 +15,6 @@
 
 (** Research of elements through modules. *)
 
-module Name = Odoc_name
-open Odoc_parameter
 open Odoc_value
 open Odoc_type
 open Odoc_extension
@@ -93,7 +91,7 @@ module Search =
       | T.Module_list _
       | T.Index_list -> []
       | T.Target _ -> []
-      | T.Title (n, l_opt, t) ->
+      | T.Title (_, l_opt, t) ->
           (match l_opt with
             None -> []
           | Some s -> search_section t (Name.concat root s) v) @
diff --git a/ocamldoc/odoc_see_lexer.mll b/ocamldoc/odoc_see_lexer.mll
index b676154d..1962d50d 100644
--- a/ocamldoc/odoc_see_lexer.mll
+++ b/ocamldoc/odoc_see_lexer.mll
@@ -18,7 +18,6 @@ let print_DEBUG2 s = print_string s ; print_newline ()
 
 (** the lexer for special comments. *)
 
-open Lexing
 open Odoc_parser
 
 let buf = Buffer.create 32
diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml
index 8859ca2e..ff1e9a57 100644
--- a/ocamldoc/odoc_sig.ml
+++ b/ocamldoc/odoc_sig.ml
@@ -18,12 +18,9 @@
 open Misc
 open Asttypes
 open Types
-open Typedtree
-open Path
 
 let print_DEBUG s = print_string s ; print_newline ();;
 
-module Name = Odoc_name
 open Odoc_parameter
 open Odoc_value
 open Odoc_type
@@ -43,7 +40,6 @@ module Signature_search =
       | C of string
       | CT of string
       | X of string
-      | P of string
 
     type tab = (ele, Types.signature_item) Hashtbl.t
 
@@ -96,7 +92,7 @@ module Signature_search =
 
     let search_module table name =
       match Hashtbl.find table (M name) with
-      | (Types.Sig_module (ident, md, _)) -> md.Types.md_type
+      | (Types.Sig_module (_ident, md, _)) -> md.Types.md_type
       | _ -> assert false
 
     let search_module_type table name =
@@ -131,6 +127,7 @@ module Analyser =
   struct
     (** This variable is used to load a file as a string and retrieve characters from it.*)
     let file = ref ""
+
     (** The name of the analysed file. *)
     let file_name = ref ""
 
@@ -144,6 +141,26 @@ module Analyser =
         Invalid_argument _ ->
           ""
 
+    let just_after_special start stop =
+      let s = get_string_of_file start stop in
+      My_ir.just_after_special !file_name s
+
+    (** Helper functions for extracting location*)
+    module Loc = struct
+      let gen proj =
+        (fun ct -> (proj ct).Location.loc_start.Lexing.pos_cnum),
+        (fun ct -> (proj ct).Location.loc_end.Lexing.pos_cnum)
+    let ptyp' ct = ct.Parsetree.ptyp_loc
+    let pcd' pcd = pcd.Parsetree.pcd_loc
+    let loc' loc = loc
+    let psig' p = p.Parsetree.psig_loc
+
+    let start, end_ = gen loc'
+    let ptyp_start, ptyp_end = gen ptyp'
+    let pcd_start, pcd_end = gen pcd'
+    let psig_start, psig_end = gen psig'
+    end
+
     (** This function loads the given file in the file global variable,
        and sets file_name.*)
     let prepare_file f input_f =
@@ -170,6 +187,90 @@ module Analyser =
 
     let merge_infos = Odoc_merge.merge_info_opt Odoc_types.all_merge_options
 
+    (** Module for extracting documentation comments for record from different
+        tree types *)
+    module Record = struct
+
+      (** A structure to abstract over the tree type *)
+      type ('a,'b,'c) projector = {
+        name:'a -> string;
+        inline_record: 'b -> 'c option;
+        inline_end: 'b -> int;
+        start:'a -> int;
+        end_: 'a -> int }
+
+    (** A function to extract documentation from a list of label declarations *)
+    let doc p pos_end ld =
+      let rec f = function
+        | [] -> []
+        | ld :: [] ->
+            let name = p.name ld in
+            let pos = p.end_ ld in
+            let (_,comment_opt) =  just_after_special pos pos_end in
+            [name, comment_opt]
+        | ld  :: ele2 :: q ->
+            let pos = p.end_ ld in
+            let pos2 = p.start ele2 in
+            let name = p.name ld in
+            let (_,comment_opt) = just_after_special pos pos2 in
+            (name, comment_opt) :: (f (ele2 :: q))
+      in
+      f ld
+
+    let inline_doc p cstr =
+      match p.inline_record cstr with
+      | None -> []
+      | Some r ->
+          doc p (p.inline_end cstr) r
+
+    (** The three tree types used in the rest of the source: *)
+
+    let parsetree =
+      let open Parsetree in
+      { name = (fun ld -> ld.pld_name.txt );
+        start = (fun ld -> Loc.ptyp_start ld.pld_type);
+        end_ =  (fun ld -> Loc.ptyp_end ld.pld_type);
+        inline_record = begin
+          fun c -> match c.pcd_args with
+            | Pcstr_tuple _ -> None
+            | Pcstr_record r -> Some r
+        end;
+        inline_end = (fun c -> Loc.end_ c.pcd_loc)
+      }
+
+    let types =
+      let open Types in
+      { name = (fun ld -> ld.ld_id.Ident.name );
+        start = (fun ld -> Loc.start ld.ld_loc);
+        end_ =  (fun ld -> Loc.start ld.ld_loc);
+        (* Beware, Loc.start is correct in the code above:
+           type_expr's do not hold location information, and ld.ld_loc
+           ends after the documentation comment, sow e use Loc.start as
+           the least problematic approximation for end_. *)
+        inline_record = begin
+          fun c -> match c.cd_args with
+            | Cstr_tuple _ -> None
+            | Cstr_record r -> Some r
+        end;
+        inline_end = (fun c -> Loc.end_ c.cd_loc)
+      }
+
+    let typedtree =
+      let open Typedtree in
+      { name = (fun ld -> ld.ld_id.Ident.name );
+        start = (fun ld -> Loc.start ld.ld_type.ctyp_loc);
+        end_ =  (fun ld -> Loc.end_ ld.ld_type.ctyp_loc);
+        inline_record = begin
+          fun c -> match c.cd_args with
+            | Cstr_tuple _ -> None
+            | Cstr_record r -> Some r
+        end;
+        inline_end = (fun c -> Loc.end_ c.cd_loc)
+      }
+
+
+    end
+
     let name_comment_from_type_decl pos_end pos_limit ty_decl =
       match ty_decl.Parsetree.ptype_kind with
       | Parsetree.Ptype_abstract ->
@@ -186,15 +287,13 @@ module Analyser =
                 assert false
 
               | (name, _atts, ct) :: [] ->
-                let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in
-                let s = get_string_of_file pos pos_end in
-                let (_,comment_opt) =  My_ir.just_after_special !file_name s in
+                let pos = Loc.ptyp_end ct in
+                let (_,comment_opt) = just_after_special pos pos_end in
                 [name, comment_opt]
-              | (name, _atts, ct) :: ((name2, _atts2, ct2) as ele2) :: q ->
-                let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in
-                let pos2 = ct2.Parsetree.ptyp_loc.Location.loc_start.Lexing.pos_cnum in
-                let s = get_string_of_file pos pos2 in
-                let (_,comment_opt) =  My_ir.just_after_special !file_name s in
+              | (name, _atts, ct) :: ((_name2, _atts2, ct2) as ele2) :: q ->
+                let pos = Loc.ptyp_end ct in
+                let pos2 = Loc.ptyp_start ct2 in
+                let (_,comment_opt) = just_after_special pos pos2 in
                 (name, comment_opt) :: (f (ele2 :: q))
             in
             let is_named_field field =
@@ -215,40 +314,22 @@ module Analyser =
               [] ->
                 (0, acc)
             | pcd :: [] ->
-                let s = get_string_of_file
-                    pcd.pcd_loc.Location.loc_end.Lexing.pos_cnum
-                    pos_limit
-                in
-                let (len, comment_opt) =  My_ir.just_after_special !file_name s in
-                (len, acc @ [ (pcd.pcd_name.txt, comment_opt) ])
+                let acc = Record.(inline_doc parsetree) pcd @ acc in
+                let (len, comment_opt) =
+                  just_after_special (Loc.pcd_end pcd) pos_limit in
+                (len, List.rev @@ (pcd.pcd_name.txt, comment_opt):: acc )
             | pcd :: (pcd2 :: _ as q) ->
-                (* TODO: support annotations on fields for inline records *)
-                let pos_end_first = pcd.pcd_loc.Location.loc_end.Lexing.pos_cnum in
-                let pos_start_second = pcd2.pcd_loc.Location.loc_start.Lexing.pos_cnum in
-                let s = get_string_of_file pos_end_first pos_start_second in
-                let (_,comment_opt) = My_ir.just_after_special !file_name  s in
-                f (acc @ [pcd.pcd_name.txt, comment_opt]) q
+                let acc = Record.(inline_doc parsetree) pcd @ acc in
+                let pos_end_first = Loc.pcd_end pcd in
+                let pos_start_second = Loc.pcd_start pcd2 in
+                let (_,comment_opt) =
+                  just_after_special pos_end_first pos_start_second in
+                f ((pcd.pcd_name.txt, comment_opt)::acc) q
           in
           f [] cons_core_type_list_list
 
-      | Parsetree.Ptype_record name_mutable_type_list (* of (string * mutable_flag * core_type) list*) ->
-          let open Parsetree in
-          let rec f = function
-              [] ->
-                []
-            | {pld_name=name; pld_type=ct} :: [] ->
-                let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in
-                let s = get_string_of_file pos pos_end in
-                let (_,comment_opt) =  My_ir.just_after_special !file_name s in
-                [name.txt, comment_opt]
-            | {pld_name=name; pld_type=ct} :: ({pld_name=name2; pld_type=ct2} as ele2) :: q ->
-                let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in
-                let pos2 = ct2.Parsetree.ptyp_loc.Location.loc_start.Lexing.pos_cnum in
-                let s = get_string_of_file pos pos2 in
-                let (_,comment_opt) =  My_ir.just_after_special !file_name s in
-                (name.txt, comment_opt) :: (f (ele2 :: q))
-          in
-          (0, f name_mutable_type_list)
+      | Parsetree.Ptype_record label_declaration_list ->
+          (0, Record.(doc parsetree) pos_end label_declaration_list)
       | Parsetree.Ptype_open ->
           (0, [])
 
@@ -298,7 +379,8 @@ module Analyser =
             let vc_args =
               match cd_args with
               | Cstr_tuple l -> Cstr_tuple (List.map (Odoc_env.subst_type env) l)
-              | Cstr_record l -> Cstr_record (List.map (get_field env []) l)
+              | Cstr_record l ->
+                  Cstr_record (List.map (get_field env name_comment_list) l)
             in
             {
               vc_name = constructor_name ;
@@ -316,6 +398,21 @@ module Analyser =
           Odoc_type.Type_open
 
 
+    let get_cstr_args env pos_end =
+      let tuple ct = Odoc_env.subst_type env ct.Typedtree.ctyp_type in
+      let record comments
+          { Typedtree.ld_id; ld_mutable; ld_type; ld_loc; ld_attributes } =
+        get_field env comments @@
+        {Types.ld_id; ld_mutable; ld_type=ld_type.Typedtree.ctyp_type;
+         ld_loc; ld_attributes } in
+      let open Typedtree in
+      function
+      | Cstr_tuple l ->
+          Odoc_type.Cstr_tuple (List.map tuple l)
+      | Cstr_record l ->
+          let comments = Record.(doc typedtree) pos_end l in
+          Odoc_type.Cstr_record (List.map (record comments) l)
+
     let erased_names_of_constraints constraints acc =
       List.fold_right (fun constraint_ acc ->
         match constraint_ with
@@ -365,9 +462,9 @@ module Analyser =
               Parsetree.Pctf_val (_, _, _, _)
             | Parsetree.Pctf_method (_, _, _, _)
             | Parsetree.Pctf_constraint (_, _)
-            | Parsetree.Pctf_attribute _ -> loc.Location.loc_start.Lexing.pos_cnum
+            | Parsetree.Pctf_attribute _ -> Loc.start loc
             | Parsetree.Pctf_inherit class_type ->
-                class_type.Parsetree.pcty_loc.Location.loc_start.Lexing.pos_cnum
+                Loc.start class_type.Parsetree.pcty_loc
             | Parsetree.Pctf_extension _ -> assert false
       in
       let get_method name comment_opt private_flag loc q =
@@ -395,7 +492,7 @@ module Analyser =
           }
         in
         let pos_limit2 = get_pos_limit2 q in
-        let pos_end = loc.Location.loc_end.Lexing.pos_cnum in
+        let pos_end = Loc.end_ loc in
         let (maybe_more, info_after_opt) =
           My_ir.just_after_special
             !file_name
@@ -430,7 +527,8 @@ module Analyser =
 
         | Parsetree.Pctf_val (name, mutable_flag, virtual_flag, _) ->
             (* of (string * mutable_flag * core_type option * Location.t)*)
-            let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
+            let (comment_opt, eles_comments) = get_comments_in_class last_pos
+                (Loc.start loc) in
             let complete_name = Name.concat current_class_name name in
             let typ =
               try Signature_search.search_attribute_type name class_signature
@@ -455,7 +553,7 @@ module Analyser =
               }
             in
             let pos_limit2 = get_pos_limit2 q in
-            let pos_end = loc.Location.loc_end.Lexing.pos_cnum in
+            let pos_end = Loc.end_ loc in
             let (maybe_more, info_after_opt) =
               My_ir.just_after_special
                 !file_name
@@ -467,34 +565,33 @@ module Analyser =
 
         | Parsetree.Pctf_method (name, private_flag, virtual_flag, _) ->
             (* of (string * private_flag * virtual_flag * core_type) *)
-            let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
+            let (comment_opt, eles_comments) =
+              get_comments_in_class last_pos (Loc.start  loc) in
             let (met, maybe_more) = get_method name comment_opt private_flag loc q in
             let met2 =
               match virtual_flag with
               | Concrete -> met
               | Virtual -> { met with met_virtual = true }
             in
-            let (inher_l, eles) = f (loc.Location.loc_end.Lexing.pos_cnum + maybe_more) q in
+            let (inher_l, eles) = f (Loc.end_ loc + maybe_more) q in
             (inher_l, eles_comments @ ((Class_method met2) :: eles))
 
         | (Parsetree.Pctf_constraint (_, _)) ->
             (* of (core_type * core_type) *)
             (* FIXME: this corresponds to constraints, isn't it? We don't keep them for now *)
-            let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
-            let (inher_l, eles) = f loc.Location.loc_end.Lexing.pos_cnum q in
+            let (_comment_opt, eles_comments) = get_comments_in_class last_pos
+                (Loc.start loc) in
+            let (inher_l, eles) = f (Loc.end_ loc) q in
             (inher_l, eles_comments @ eles)
 
         | Parsetree.Pctf_inherit class_type ->
             let loc = class_type.Parsetree.pcty_loc in
             let (comment_opt, eles_comments) =
-              get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum
-            in
+              get_comments_in_class last_pos (Loc.start loc) in
             let pos_limit2 = get_pos_limit2 q in
-            let pos_end = loc.Location.loc_end.Lexing.pos_cnum in
+            let pos_end = Loc.end_ loc in
             let (maybe_more, info_after_opt) =
-              My_ir.just_after_special
-                !file_name
-                (get_string_of_file pos_end pos_limit2)
+             just_after_special pos_end pos_limit2
             in
             let comment_opt2 = merge_infos comment_opt info_after_opt in
             let text_opt = match comment_opt2 with None -> None | Some i -> i.Odoc_types.i_desc in
@@ -522,8 +619,9 @@ module Analyser =
             let (inher_l, eles) = f (pos_end + maybe_more) q in
             (inh :: inher_l , eles_comments @ eles)
         | Parsetree.Pctf_attribute _ ->
-            let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
-            let (inher_l, eles) = f loc.Location.loc_end.Lexing.pos_cnum q in
+            let (_comment_opt, eles_comments) =
+              get_comments_in_class last_pos (Loc.start loc) in
+            let (inher_l, eles) = f (Loc.end_ loc) q in
             (inher_l, eles_comments @ eles)
 
         | Parsetree.Pctf_extension _ -> assert false
@@ -554,9 +652,8 @@ module Analyser =
             acc_eles @ ele_comments
 
         | ele :: q ->
-            let (assoc_com, ele_comments) =  get_comments_in_module
-                last_pos
-                ele.Parsetree.psig_loc.Location.loc_start.Lexing.pos_cnum
+            let (assoc_com, ele_comments) =
+              get_comments_in_module last_pos (Loc.psig_start ele)
             in
             let (maybe_more, new_env, elements) = analyse_signature_item_desc
                 acc_env
@@ -564,17 +661,16 @@ module Analyser =
                 table
                 current_module_name
                 ele.Parsetree.psig_loc
-                ele.Parsetree.psig_loc.Location.loc_start.Lexing.pos_cnum
-                ele.Parsetree.psig_loc.Location.loc_end.Lexing.pos_cnum
+                (Loc.psig_start ele)
+                (Loc.psig_end ele)
                 (match q with
                   [] -> pos_limit
-                | ele2 :: _ -> ele2.Parsetree.psig_loc.Location.loc_start.Lexing.pos_cnum
+                | ele2 :: _ -> Loc.psig_start ele2
                 )
                 assoc_com
                 ele.Parsetree.psig_desc
             in
-            let new_pos =
-              ele.Parsetree.psig_loc.Location.loc_end.Lexing.pos_cnum + maybe_more
+            let new_pos = Loc.psig_end ele + maybe_more
               (* for the comments of constructors in types,
                  which are after the constructor definition and can
                  go beyond ele.Parsetree.psig_loc.Location.loc_end.Lexing.pos_cnum *)
@@ -588,7 +684,7 @@ module Analyser =
 
     (** Analyse the given signature_item_desc to create the corresponding module element
        (with the given attached comment).*)
-    and analyse_signature_item_desc env signat table current_module_name
+    and analyse_signature_item_desc env _signat table current_module_name
         sig_item_loc pos_start_ele pos_end_ele pos_limit comment_opt sig_item_desc =
         match sig_item_desc with
           Parsetree.Psig_value value_desc ->
@@ -639,6 +735,7 @@ module Analyser =
               (env, [], None)
               tyext.Parsetree.ptyext_constructors
           in
+          let types_ext_list = List.rev types_ext_list in
           let ty_path, ty_params, priv =
             match last_ext with
               None -> assert false
@@ -667,11 +764,14 @@ module Analyser =
             match types_ext_list with
               [] -> (maybe_more, List.rev exts_acc)
             | (name, types_ext) :: q ->
-              let ext_loc_end =  types_ext.Types.ext_loc.Location.loc_end.Lexing.pos_cnum in
+              let ext_loc_end =  Loc.end_ types_ext.Types.ext_loc in
               let xt_args =
                 match types_ext.ext_args with
-                | Cstr_tuple l -> Cstr_tuple (List.map (Odoc_env.subst_type new_env) l)
-                | Cstr_record l -> Cstr_record (List.map (get_field new_env []) l)
+                | Cstr_tuple l ->
+                    Cstr_tuple (List.map (Odoc_env.subst_type new_env) l)
+                | Cstr_record l ->
+                    let docs = Record.(doc types ext_loc_end) l in
+                    Cstr_record (List.map (get_field new_env docs) l)
               in
               let new_x =
                 {
@@ -687,19 +787,17 @@ module Analyser =
               let pos_limit2 =
                 match q with
                   [] -> pos_limit
-                | (_, next) :: _ -> next.Types.ext_loc.Location.loc_start.Lexing.pos_cnum
+                | (_, next) :: _ -> Loc.start (next.Types.ext_loc)
               in
-              let s = get_string_of_file ext_loc_end pos_limit2 in
-              let (maybe_more, comment_opt) =  My_ir.just_after_special !file_name s in
+              let (maybe_more, comment_opt) =
+                just_after_special ext_loc_end pos_limit2 in
                 new_x.xt_text <- comment_opt;
                 analyse_extension_constructors maybe_more (new_x :: exts_acc) q
           in
           let (maybe_more, exts) = analyse_extension_constructors 0 [] types_ext_list in
             new_te.te_constructors <- exts;
             let (maybe_more2, info_after_opt) =
-              My_ir.just_after_special
-                !file_name
-                (get_string_of_file (pos_end_ele + maybe_more) pos_limit)
+              just_after_special (pos_end_ele + maybe_more) pos_limit
             in
               new_te.te_info <- merge_infos new_te.te_info info_after_opt ;
               (maybe_more + maybe_more2, new_env, [ Element_type_extension new_te ])
@@ -712,9 +810,12 @@ module Analyser =
                 raise (Failure (Odoc_messages.exception_not_found current_module_name name.txt))
             in
             let ex_args =
+              let pos_end = Loc.end_ types_ext.ext_loc in
               match types_ext.ext_args with
               | Cstr_tuple l -> Cstr_tuple (List.map (Odoc_env.subst_type env) l)
-              | Cstr_record l -> Cstr_record (List.map (get_field env []) l)
+              | Cstr_record l ->
+                  let docs = Record.(doc types) pos_end l in
+                  Cstr_record (List.map (get_field env docs) l)
             in
             let e =
               {
@@ -769,16 +870,16 @@ module Analyser =
                     else
                       get_comments_in_module
                         last_pos
-                        type_decl.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum
+                        (Loc.start type_decl.Parsetree.ptype_loc)
                   in
                   let pos_limit2 =
                     match q with
                       [] -> pos_limit
-                    | td :: _ -> td.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum
+                    | td :: _ -> Loc.start (td.Parsetree.ptype_loc)
                   in
                   let (maybe_more, name_comment_list) =
                     name_comment_from_type_decl
-                      type_decl.Parsetree.ptype_loc.Location.loc_end.Lexing.pos_cnum
+                      (Loc.end_ type_decl.Parsetree.ptype_loc)
                       pos_limit2
                       type_decl
                   in
@@ -807,8 +908,9 @@ module Analyser =
                   in
                   (* get the type kind with the associated comments *)
                   let type_kind = get_type_kind env name_comment_list sig_type_decl.Types.type_kind in
-                  let loc_start = type_decl.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum in
-                  let new_end = type_decl.Parsetree.ptype_loc.Location.loc_end.Lexing.pos_cnum + maybe_more in
+                  let loc_start = Loc.start type_decl.Parsetree.ptype_loc in
+                  let new_end = Loc.end_ type_decl.Parsetree.ptype_loc
+                                + maybe_more in
                   (* associate the comments to each constructor and build the [Type.t_type] *)
                   let new_type =
                     {
@@ -876,8 +978,8 @@ module Analyser =
             let code_intf =
               if !Odoc_global.keep_code then
                 let loc = module_type.Parsetree.pmty_loc in
-                let st = loc.Location.loc_start.Lexing.pos_cnum in
-                let en = loc.Location.loc_end.Lexing.pos_cnum in
+                let st = Loc.start loc in
+                let en = Loc.end_ loc in
                 Some (get_string_of_file st en)
               else
                 None
@@ -942,8 +1044,8 @@ module Analyser =
               | {Parsetree.pmd_name=name; pmd_type=modtype} :: q ->
                   let complete_name = Name.concat current_module_name name.txt in
                   let loc = modtype.Parsetree.pmty_loc in
-                  let loc_start = loc.Location.loc_start.Lexing.pos_cnum in
-                  let loc_end = loc.Location.loc_end.Lexing.pos_cnum in
+                  let loc_start = Loc.start loc in
+                  let loc_end = Loc.end_ loc in
                   let (assoc_com, ele_comments) =
                     if first then
                       (comment_opt, [])
@@ -955,7 +1057,7 @@ module Analyser =
                   let pos_limit2 =
                     match q with
                       [] -> pos_limit
-                    | _ :: _ -> loc.Location.loc_start.Lexing.pos_cnum
+                    | _ :: _ -> Loc.start loc
                   in
                   (* get the information for the module in the signature *)
                   let sig_module_type =
@@ -967,8 +1069,8 @@ module Analyser =
                   let module_kind = analyse_module_kind new_env complete_name modtype sig_module_type in
                   let code_intf =
                     if !Odoc_global.keep_code then
-                      let st = loc.Location.loc_start.Lexing.pos_cnum in
-                      let en = loc.Location.loc_end.Lexing.pos_cnum in
+                      let st = Loc.start loc in
+                      let en = Loc.end_ loc in
                       Some (get_string_of_file st en)
                     else
                       None
@@ -1098,14 +1200,13 @@ module Analyser =
                     else
                       get_comments_in_module
                         last_pos
-                        class_desc.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
+                        (Loc.start class_desc.Parsetree.pci_loc)
                   in
-                  let pos_end = class_desc.Parsetree.pci_loc.Location.loc_end.Lexing.pos_cnum in
+                  let pos_end = Loc.end_ class_desc.Parsetree.pci_loc in
                   let pos_limit2 =
                     match q with
                       [] -> pos_limit
-                    | cd :: _ -> cd.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
-                  in
+                    | cd :: _ -> Loc.start cd.Parsetree.pci_loc in
                   let name = class_desc.Parsetree.pci_name in
                   let complete_name = Name.concat current_module_name name.txt in
                   let sig_class_decl =
@@ -1118,7 +1219,7 @@ module Analyser =
                     analyse_class_kind
                      new_env
                      complete_name
-                     class_desc.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
+                     (Loc.start class_desc.Parsetree.pci_loc)
                      class_desc.Parsetree.pci_expr
                      sig_class_type
                  in
@@ -1135,10 +1236,7 @@ module Analyser =
                    }
                  in
                  let (maybe_more, info_after_opt) =
-                   My_ir.just_after_special
-                     !file_name
-                     (get_string_of_file pos_end pos_limit2)
-                 in
+                   just_after_special pos_end pos_limit2 in
                  new_class.cl_info <- merge_infos new_class.cl_info info_after_opt ;
                  Odoc_class.class_update_parameters_text new_class ;
                  let (new_maybe_more, eles) =
@@ -1174,13 +1272,13 @@ module Analyser =
                     else
                       get_comments_in_module
                         last_pos
-                        ct_decl.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
+                        (Loc.start ct_decl.Parsetree.pci_loc)
                   in
-                  let pos_end = ct_decl.Parsetree.pci_loc.Location.loc_end.Lexing.pos_cnum in
+                  let pos_end = Loc.end_ ct_decl.Parsetree.pci_loc in
                   let pos_limit2 =
                     match q with
                       [] -> pos_limit
-                    | ct_decl2 :: _ -> ct_decl2.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
+                    | ct_decl2 :: _ -> Loc.start ct_decl2.Parsetree.pci_loc
                   in
                   let name = ct_decl.Parsetree.pci_name in
                   let complete_name = Name.concat current_module_name name.txt in
@@ -1193,7 +1291,7 @@ module Analyser =
                   let kind = analyse_class_type_kind
                       new_env
                       complete_name
-                      ct_decl.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
+                      (Loc.start ct_decl.Parsetree.pci_loc)
                       ct_decl.Parsetree.pci_expr
                       sig_class_type
                   in
@@ -1209,9 +1307,7 @@ module Analyser =
                     }
                   in
                   let (maybe_more, info_after_opt) =
-                    My_ir.just_after_special
-                      !file_name
-                      (get_string_of_file pos_end pos_limit2)
+                    just_after_special pos_end pos_limit2
                   in
                   ct.clt_info <- merge_infos ct.clt_info info_after_opt ;
                   let (new_maybe_more, eles) =
@@ -1245,7 +1341,7 @@ module Analyser =
       | Parsetree.Pmty_alias longident ->
           let name =
             match sig_module_type with
-              Types.Mty_alias path -> Name.from_path path
+              Types.Mty_alias(_, path) -> Name.from_path path
             | _ -> Name.from_longident longident.txt
           in
           (* Wrong naming... *)
@@ -1258,8 +1354,8 @@ module Analyser =
            (* we must have a signature in the module type *)
            match sig_module_type with
              Types.Mty_signature signat ->
-               let pos_start = module_type.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in
-               let pos_end = module_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
+               let pos_start = Loc.start module_type.Parsetree.pmty_loc in
+               let pos_end = Loc.end_ module_type.Parsetree.pmty_loc in
                let elements = analyse_parsetree env signat current_module_name pos_start pos_end ast in
                Module_type_struct elements
            | _ ->
@@ -1270,8 +1366,8 @@ module Analyser =
           (
            let loc = match pmodule_type2 with None -> Location.none
                      | Some pmty -> pmty.Parsetree.pmty_loc in
-           let loc_start = loc.Location.loc_start.Lexing.pos_cnum in
-           let loc_end = loc.Location.loc_end.Lexing.pos_cnum in
+           let loc_start = Loc.start loc in
+           let loc_end = Loc.end_ loc in
            let mp_type_code = get_string_of_file loc_start loc_end in
            print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code);
            match sig_module_type with
@@ -1307,8 +1403,8 @@ module Analyser =
       | Parsetree.Pmty_with (module_type2, constraints) ->
           (* of module_type * (Longident.t * with_constraint) list *)
           (
-           let loc_start = module_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
-           let loc_end = module_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
+           let loc_start = Loc.end_ module_type2.Parsetree.pmty_loc in
+           let loc_end = Loc.end_ module_type.Parsetree.pmty_loc in
            let s = get_string_of_file loc_start loc_end in
            let erased = erased_names_of_constraints constraints erased in
            let k = analyse_module_type_kind ~erased env current_module_name module_type2 sig_module_type in
@@ -1317,8 +1413,8 @@ module Analyser =
           )
 
       | Parsetree.Pmty_typeof module_expr ->
-          let loc_start = module_expr.Parsetree.pmod_loc.Location.loc_start.Lexing.pos_cnum in
-          let loc_end = module_expr.Parsetree.pmod_loc.Location.loc_end.Lexing.pos_cnum in
+          let loc_start = Loc.start module_expr.Parsetree.pmod_loc in
+          let loc_end = Loc.end_ module_expr.Parsetree.pmod_loc in
           let s = get_string_of_file loc_start loc_end in
           Module_type_typeof s
 
@@ -1328,13 +1424,13 @@ module Analyser =
     and analyse_module_kind
         ?(erased = Name.Set.empty) env current_module_name module_type sig_module_type =
       match module_type.Parsetree.pmty_desc with
-      | Parsetree.Pmty_ident longident ->
+      | Parsetree.Pmty_ident _longident ->
           let k = analyse_module_type_kind env current_module_name module_type sig_module_type in
           Module_with ( k, "" )
-      | Parsetree.Pmty_alias longident ->
+      | Parsetree.Pmty_alias _longident ->
           begin
             match sig_module_type with
-              Types.Mty_alias path ->
+              Types.Mty_alias(_, path) ->
                 let alias_name = Odoc_env.full_module_name env (Name.from_path path) in
                 let ma = { ma_name = alias_name ; ma_module = None } in
                 Module_alias ma
@@ -1351,8 +1447,8 @@ module Analyser =
                     env
                     signat
                     current_module_name
-                    module_type.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum
-                    module_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum
+                    (Loc.start module_type.Parsetree.pmty_loc)
+                    (Loc.end_ module_type.Parsetree.pmty_loc)
                     signature
                  )
            | _ ->
@@ -1365,8 +1461,8 @@ module Analyser =
              Types.Mty_functor (ident, param_module_type, body_module_type) ->
                let loc = match pmodule_type2 with None -> Location.none
                      | Some pmty -> pmty.Parsetree.pmty_loc in
-               let loc_start = loc.Location.loc_start.Lexing.pos_cnum in
-               let loc_end = loc.Location.loc_end.Lexing.pos_cnum in
+               let loc_start = Loc.start loc in
+               let loc_end = Loc.end_ loc in
                let mp_type_code = get_string_of_file loc_start loc_end in
                print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code);
                let mp_kind =
@@ -1398,16 +1494,16 @@ module Analyser =
       | Parsetree.Pmty_with (module_type2, constraints) ->
           (*of module_type * (Longident.t * with_constraint) list*)
           (
-           let loc_start = module_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
-           let loc_end = module_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
+           let loc_start = Loc.end_ module_type2.Parsetree.pmty_loc in
+           let loc_end = Loc.end_ module_type.Parsetree.pmty_loc in
            let s = get_string_of_file loc_start loc_end in
            let erased = erased_names_of_constraints constraints erased in
            let k = analyse_module_type_kind ~erased env current_module_name module_type2 sig_module_type in
            Module_with (k, s)
           )
       | Parsetree.Pmty_typeof module_expr ->
-          let loc_start = module_expr.Parsetree.pmod_loc.Location.loc_start.Lexing.pos_cnum in
-          let loc_end = module_expr.Parsetree.pmod_loc.Location.loc_end.Lexing.pos_cnum in
+          let loc_start = Loc.start module_expr.Parsetree.pmod_loc in
+          let loc_end = Loc.end_ module_expr.Parsetree.pmod_loc in
           let s = get_string_of_file loc_start loc_end in
           Module_typeof s
 
@@ -1437,7 +1533,7 @@ module Analyser =
           (* we get the elements of the class in class_type_field_list *)
           let (inher_l, ele) = analyse_class_elements env current_class_name
               last_pos
-              parse_class_type.Parsetree.pcty_loc.Location.loc_end.Lexing.pos_cnum
+              (Loc.end_ parse_class_type.Parsetree.pcty_loc)
               class_type_field_list
               class_signature
           in
@@ -1485,13 +1581,13 @@ module Analyser =
           (* we get the elements of the class in class_type_field_list *)
           let (inher_l, ele) = analyse_class_elements env current_class_name
               last_pos
-              parse_class_type.Parsetree.pcty_loc.Location.loc_end.Lexing.pos_cnum
+              (Loc.end_ parse_class_type.Parsetree.pcty_loc)
               class_type_field_list
               class_signature
           in
           Class_signature (inher_l, ele)
 
-      | (Parsetree.Pcty_arrow (parse_label, _, pclass_type), Types.Cty_arrow (label, type_expr, class_type)) ->
+      | (Parsetree.Pcty_arrow _, Types.Cty_arrow _) ->
           raise (Failure "analyse_class_type_kind : Parsetree.Pcty_arrow (...) with Types.Cty_arrow (...)")
 (*
       | (Parsetree.Pcty_constr (longident, _) (*of Longident.t * core_type list *),
diff --git a/ocamldoc/odoc_sig.mli b/ocamldoc/odoc_sig.mli
index 65e7b373..b5318987 100644
--- a/ocamldoc/odoc_sig.mli
+++ b/ocamldoc/odoc_sig.mli
@@ -157,6 +157,13 @@ module Analyser :
           Odoc_env.env -> (string * Odoc_types.info option) list ->
             Types.type_kind -> Odoc_type.type_kind
 
+      (** This function converts a [Types.constructor_arguments] into a
+          [Odoc_type.constructor_args], by associating the comment found
+          in the parsetree of each inner record field, if any.*)
+      val get_cstr_args:
+        Odoc_env.env -> int -> Typedtree.constructor_arguments ->
+        Odoc_type.constructor_args
+
       (** This function merge two optional info structures. *)
       val merge_infos :
           Odoc_types.info option -> Odoc_types.info option ->
diff --git a/ocamldoc/odoc_str.ml b/ocamldoc/odoc_str.ml
index bfaea763..44d03db1 100644
--- a/ocamldoc/odoc_str.ml
+++ b/ocamldoc/odoc_str.ml
@@ -298,8 +298,11 @@ let string_of_type_extension te =
                            (List.map
                               (fun t -> "("^Odoc_print.string_of_type_expr t^")") l))
                       ^ " -> " ^ Odoc_print.string_of_type_expr r
-                  | T.Cstr_record _, _ ->
-                      assert false
+                  | T.Cstr_record l, None ->
+                      " of " ^  string_of_record l
+                  | T.Cstr_record l, Some r ->
+                      " : " ^ string_of_record l ^ " -> "
+                      ^ Odoc_print.string_of_type_expr r
                )
               ^(match x.M.xt_alias with
                     None -> ""
@@ -342,8 +345,11 @@ let string_of_exception e =
          (List.map (fun t -> "("^(Odoc_print.string_of_type_expr t)^")") l))^
        " -> "^
        (Odoc_print.string_of_type_expr r)
-   | T.Cstr_record _, _ ->
-       assert false
+   | T.Cstr_record l, None ->
+       " of " ^  string_of_record l
+   | T.Cstr_record l, Some r ->
+       " : " ^ string_of_record l ^ " -> "
+       ^ Odoc_print.string_of_type_expr r
   )^
   (match e.M.ex_alias with
     None -> ""
diff --git a/ocamldoc/odoc_test.ml b/ocamldoc/odoc_test.ml
index dd026475..dec7a1ec 100644
--- a/ocamldoc/odoc_test.ml
+++ b/ocamldoc/odoc_test.ml
@@ -117,7 +117,7 @@ struct
     object
       inherit G.generator as base
 
-      method generate l =
+      method! generate l =
         base#generate l;
         g#generate l
     end
diff --git a/ocamldoc/odoc_texi.ml b/ocamldoc/odoc_texi.ml
index eeaa2105..b52e0358 100644
--- a/ocamldoc/odoc_texi.ml
+++ b/ocamldoc/odoc_texi.ml
@@ -16,7 +16,6 @@
 (** Generation of Texinfo documentation. *)
 
 open Odoc_info
-open Parameter
 open Value
 open Type
 open Extension
@@ -273,7 +272,7 @@ class text =
 
     (** this method is not used here but is virtual
         in a class we will inherit later *)
-    method label ?(no_ : bool option) (_ : string) : string =
+    method label ?no_:(_ : bool option) (_ : string) : string =
       failwith "gni"
 
     (** Return the Texinfo code corresponding to the [text] parameter.*)
@@ -311,7 +310,7 @@ class text =
       | Odoc_info.Custom (s,t) -> self#texi_of_custom_text s t
       | Odoc_info.Target (target, code) -> self#texi_of_Target ~target ~code
 
-    method texi_of_custom_text s t = ""
+    method texi_of_custom_text _ _ = ""
 
     method texi_of_Target ~target ~code =
       if String.lowercase_ascii target = "texi" then code else ""
@@ -397,7 +396,7 @@ struct
     Texinfo documentation. *)
 class texi =
   object (self)
-    inherit text as to_texi
+    inherit text
     inherit Odoc_to_text.to_text as to_text
 
     (** {3 Small helper stuff.} *)
@@ -476,7 +475,7 @@ class texi =
                    Raw " " ; Raw s ] @ t @ [ Newline ])
            see_l)
 
-    method text_of_before l =
+    method! text_of_before l =
       List.flatten
       (List.map
         (fun x -> linebreak :: (to_text#text_of_before [x])) l)
@@ -886,7 +885,7 @@ class texi =
       self#texi_of_text t
 
     (** Return the Texinfo code for the given class element. *)
-    method texi_of_class_element class_name class_ele =
+    method texi_of_class_element _class_name class_ele =
       match class_ele with
       | Class_attribute att -> self#texi_of_attribute att
       | Class_method met -> self#texi_of_method met
diff --git a/ocamldoc/odoc_text_parser.mly b/ocamldoc/odoc_text_parser.mly
index 5e0c7127..f71ab377 100644
--- a/ocamldoc/odoc_text_parser.mly
+++ b/ocamldoc/odoc_text_parser.mly
@@ -16,8 +16,6 @@
 
 open Odoc_types
 
-let identchar =
-  "[A-Z a-z_\192-\214\216-\246\248-\255'0-9]"
 let blank = "[ \010\013\009\012]"
 
 let remove_beginning_blanks s =
diff --git a/ocamldoc/odoc_to_text.ml b/ocamldoc/odoc_to_text.ml
index a602da61..fd650510 100644
--- a/ocamldoc/odoc_to_text.ml
+++ b/ocamldoc/odoc_to_text.ml
@@ -24,7 +24,6 @@ open Type
 open Value
 open Module
 open Class
-open Parameter
 
 (** A class used to get a [text] for info structures. *)
 class virtual info =
@@ -229,7 +228,8 @@ class virtual to_text =
 
     method normal_cstr_args ?par m_name = function
       | Cstr_tuple l -> self#normal_type_list ?par m_name " * " l
-      | Cstr_record _ -> "{...}" (* TODO *)
+      | Cstr_record r -> self#relative_idents m_name
+                            (Odoc_str.string_of_record r)
 
     (** Get a string for a list of class or class type type parameters
        where all idents are relative. *)
@@ -336,22 +336,20 @@ class virtual to_text =
       Format.fprintf Format.str_formatter "@[exception %s" s_name ;
       (match e.ex_args, e.ex_ret with
          Cstr_tuple [], None -> ()
-       | Cstr_tuple l, None ->
-           Format.fprintf Format.str_formatter " %s@ %s"
-             "of"
-             (self#normal_type_list ~par: false father " * " l)
        | Cstr_tuple [], Some r ->
            Format.fprintf Format.str_formatter " %s@ %s"
              ":"
              (self#normal_type father r)
-       | Cstr_tuple l, Some r ->
+       | args, None ->
+           Format.fprintf Format.str_formatter " %s@ %s"
+             "of"
+             (self#normal_cstr_args ~par:false father args)
+       | args, Some r ->
            Format.fprintf Format.str_formatter " %s@ %s@ %s@ %s"
              ":"
-             (self#normal_type_list ~par: false father " * " l)
+             (self#normal_cstr_args ~par:false father args)
              "->"
              (self#normal_type father r)
-       | Cstr_record _, _ ->
-           assert false
       );
       (match e.ex_alias with
          None -> ()
@@ -556,7 +554,7 @@ class virtual to_text =
           [Code ((if with_def_syntax then " : " else "")^
                  Odoc_messages.struct_end^" ")]
 
-      | Module_functor (p, k)  ->
+      | Module_functor (_, k)  ->
           (if with_def_syntax then [Code " : "] else []) @
           [Code "functor ... "] @
           [Code " -> "] @
diff --git a/otherlibs/Makefile b/otherlibs/Makefile
index 8846cd23..4758bf59 100644
--- a/otherlibs/Makefile
+++ b/otherlibs/Makefile
@@ -13,13 +13,103 @@
 #*                                                                        *
 #**************************************************************************
 
-# Common Makefile for otherlibs on the Unix ports
+# Common Makefile for otherlibs
+
+ROOTDIR=../..
+include $(ROOTDIR)/config/Makefile
+CAMLRUN ?= $(ROOTDIR)/boot/ocamlrun
+CAMLYACC ?= $(ROOTDIR)/boot/ocamlyacc
+
+ifeq "$(wildcard $(ROOTDIR)/flexdll/Makefile)" ""
+export OCAML_FLEXLINK:=
+else
+export OCAML_FLEXLINK:=$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/flexdll/flexlink.exe
+endif
 
 CAMLC=$(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib
 CAMLOPT=$(CAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib \
         -I $(ROOTDIR)/stdlib
 CFLAGS=-I$(ROOTDIR)/byterun $(SHAREDCCCOMPOPTS) $(EXTRACFLAGS)
 
-include ../Makefile.shared
-# Note .. is the current directory (this makefile is included from
-# a subdirectory)
+# Compilation options
+CC=$(BYTECC)
+COMPFLAGS=-absname -w +a-4-9-41-42-44-45-48 -warn-error A -bin-annot -g \
+          -safe-string -strict-sequence -strict-formats $(EXTRACAMLFLAGS)
+ifeq "$(FLAMBDA)" "true"
+OPTCOMPFLAGS=-O3
+else
+OPTCOMPFLAGS=
+endif
+MKLIB=$(CAMLRUN) $(ROOTDIR)/tools/ocamlmklib
+
+# Variables to be defined by individual libraries:
+#LIBNAME=
+#CLIBNAME=
+#CMIFILES=
+#CAMLOBJS=
+#COBJS=
+#EXTRACFLAGS=
+#EXTRACAMLFLAGS=
+#LINKOPTS=
+#LDOPTS=
+#HEADERS=
+
+CMIFILES ?= $(CAMLOBJS:.cmo=.cmi)
+CAMLOBJS_NAT ?= $(CAMLOBJS:.cmo=.cmx)
+CLIBNAME ?= $(LIBNAME)
+
+all: lib$(CLIBNAME).$(A) $(LIBNAME).cma $(CMIFILES)
+
+allopt: lib$(CLIBNAME).$(A) $(LIBNAME).cmxa $(LIBNAME).$(CMXS) $(CMIFILES)
+
+$(LIBNAME).cma: $(CAMLOBJS)
+	$(MKLIB) -o $(LIBNAME) -oc $(CLIBNAME) -ocamlc '$(CAMLC)' -linkall \
+	         $(CAMLOBJS) $(LINKOPTS)
+
+$(LIBNAME).cmxa: $(CAMLOBJS_NAT)
+	$(MKLIB) -o $(LIBNAME) -oc $(CLIBNAME) -ocamlopt '$(CAMLOPT)' -linkall \
+	         $(CAMLOBJS_NAT) $(LINKOPTS)
+
+$(LIBNAME).cmxs: $(LIBNAME).cmxa lib$(CLIBNAME).$(A)
+	$(CAMLOPT) -shared -o $(LIBNAME).cmxs -I . $(LIBNAME).cmxa
+
+lib$(CLIBNAME).$(A): $(COBJS)
+	$(MKLIB) -oc $(CLIBNAME) $(COBJS) $(LDOPTS)
+
+INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
+INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR)
+
+install::
+	if test -f dll$(CLIBNAME)$(EXT_DLL); then \
+	  cp dll$(CLIBNAME)$(EXT_DLL) "$(INSTALL_STUBLIBDIR)/"; fi
+	cp lib$(CLIBNAME).$(A) "$(INSTALL_LIBDIR)/"
+	cd "$(INSTALL_LIBDIR)"; $(RANLIB) lib$(CLIBNAME).$(A)
+	cp $(LIBNAME).cma $(CMIFILES) $(CMIFILES:.cmi=.mli) "$(INSTALL_LIBDIR)/"
+	if test -n "$(HEADERS)"; then \
+	  cp $(HEADERS) "$(INSTALL_LIBDIR)/caml/"; fi
+
+installopt:
+	cp $(CAMLOBJS_NAT) $(LIBNAME).cmxa $(LIBNAME).$(A) "$(INSTALL_LIBDIR)/"
+	cd "$(INSTALL_LIBDIR)"; $(RANLIB) $(LIBNAME).a
+	if test -f $(LIBNAME).cmxs; then \
+	  cp $(LIBNAME).cmxs "$(INSTALL_LIBDIR)/"; fi
+
+partialclean:
+	rm -f *.cm*
+
+clean:: partialclean
+	rm -f *.dll *.so *.a *.lib *.o *.obj
+
+.SUFFIXES: .ml .mli .cmi .cmo .cmx .$(O)
+
+.mli.cmi:
+	$(CAMLC) -c $(COMPFLAGS) $<
+
+.ml.cmo:
+	$(CAMLC) -c $(COMPFLAGS) $<
+
+.ml.cmx:
+	$(CAMLOPT) -c $(COMPFLAGS) $(OPTCOMPFLAGS) $<
+
+.c.$(O):
+	$(BYTECC) $(BYTECCCOMPOPTS) $(CFLAGS) -c $<
diff --git a/otherlibs/Makefile.nt b/otherlibs/Makefile.nt
deleted file mode 100644
index e81590ac..00000000
--- a/otherlibs/Makefile.nt
+++ /dev/null
@@ -1,27 +0,0 @@
-#**************************************************************************
-#*                                                                        *
-#*                                 OCaml                                  *
-#*                                                                        *
-#*            Xavier Leroy, projet Cristal, INRIA Rocquencourt            *
-#*                                                                        *
-#*   Copyright 1999 Institut National de Recherche en Informatique et     *
-#*     en Automatique.                                                    *
-#*                                                                        *
-#*   All rights reserved.  This file is distributed under the terms of    *
-#*   the GNU Lesser General Public License version 2.1, with the          *
-#*   special exception on linking described in the file LICENSE.          *
-#*                                                                        *
-#**************************************************************************
-
-# Common Makefile for otherlibs on the Win32/MinGW ports
-
-include ../Makefile
-
-ifeq "$(wildcard $(ROOTDIR)/flexdll/Makefile)" ""
-export OCAML_FLEXLINK:=
-else
-export OCAML_FLEXLINK:=$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/flexdll/flexlink.exe
-endif
-
-# Note .. is the current directory (this makefile is included from
-# a subdirectory)
diff --git a/otherlibs/Makefile.shared b/otherlibs/Makefile.shared
deleted file mode 100644
index 58e97c22..00000000
--- a/otherlibs/Makefile.shared
+++ /dev/null
@@ -1,104 +0,0 @@
-#**************************************************************************
-#*                                                                        *
-#*                                 OCaml                                  *
-#*                                                                        *
-#*            Xavier Leroy, projet Cristal, INRIA Rocquencourt            *
-#*                                                                        *
-#*   Copyright 1999 Institut National de Recherche en Informatique et     *
-#*     en Automatique.                                                    *
-#*                                                                        *
-#*   All rights reserved.  This file is distributed under the terms of    *
-#*   the GNU Lesser General Public License version 2.1, with the          *
-#*   special exception on linking described in the file LICENSE.          *
-#*                                                                        *
-#**************************************************************************
-
-# Common Makefile for otherlibs
-
-ROOTDIR=../..
-include $(ROOTDIR)/config/Makefile
-CAMLRUN ?= $(ROOTDIR)/boot/ocamlrun
-CAMLYACC ?= $(ROOTDIR)/boot/ocamlyacc
-
-# Compilation options
-CC=$(BYTECC)
-COMPFLAGS=-w +33..39+50 -warn-error A -bin-annot -g -safe-string \
-          $(EXTRACAMLFLAGS)
-ifeq "$(FLAMBDA)" "true"
-OPTCOMPFLAGS=-O3
-else
-OPTCOMPFLAGS=
-endif
-MKLIB=$(CAMLRUN) $(ROOTDIR)/tools/ocamlmklib
-
-# Variables to be defined by individual libraries:
-#LIBNAME=
-#CLIBNAME=
-#CMIFILES=
-#CAMLOBJS=
-#COBJS=
-#EXTRACFLAGS=
-#EXTRACAMLFLAGS=
-#LINKOPTS=
-#LDOPTS=
-#HEADERS=
-
-CMIFILES ?= $(CAMLOBJS:.cmo=.cmi)
-CAMLOBJS_NAT ?= $(CAMLOBJS:.cmo=.cmx)
-CLIBNAME ?= $(LIBNAME)
-
-all: lib$(CLIBNAME).$(A) $(LIBNAME).cma $(CMIFILES)
-
-allopt: lib$(CLIBNAME).$(A) $(LIBNAME).cmxa $(LIBNAME).$(CMXS) $(CMIFILES)
-
-$(LIBNAME).cma: $(CAMLOBJS)
-	$(MKLIB) -o $(LIBNAME) -oc $(CLIBNAME) -ocamlc '$(CAMLC)' -linkall \
-	         $(CAMLOBJS) $(LINKOPTS)
-
-$(LIBNAME).cmxa: $(CAMLOBJS_NAT)
-	$(MKLIB) -o $(LIBNAME) -oc $(CLIBNAME) -ocamlopt '$(CAMLOPT)' -linkall \
-	         $(CAMLOBJS_NAT) $(LINKOPTS)
-
-$(LIBNAME).cmxs: $(LIBNAME).cmxa lib$(CLIBNAME).$(A)
-	$(CAMLOPT) -shared -o $(LIBNAME).cmxs -I . $(LIBNAME).cmxa
-
-lib$(CLIBNAME).$(A): $(COBJS)
-	$(MKLIB) -oc $(CLIBNAME) $(COBJS) $(LDOPTS)
-
-INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
-INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR)
-
-install::
-	if test -f dll$(CLIBNAME)$(EXT_DLL); then \
-	  cp dll$(CLIBNAME)$(EXT_DLL) "$(INSTALL_STUBLIBDIR)/"; fi
-	cp lib$(CLIBNAME).$(A) "$(INSTALL_LIBDIR)/"
-	cd "$(INSTALL_LIBDIR)"; $(RANLIB) lib$(CLIBNAME).$(A)
-	cp $(LIBNAME).cma $(CMIFILES) $(CMIFILES:.cmi=.mli) "$(INSTALL_LIBDIR)/"
-	if test -n "$(HEADERS)"; then \
-	  cp $(HEADERS) "$(INSTALL_LIBDIR)/caml/"; fi
-
-installopt:
-	cp $(CAMLOBJS_NAT) $(LIBNAME).cmxa $(LIBNAME).$(A) "$(INSTALL_LIBDIR)/"
-	cd "$(INSTALL_LIBDIR)"; $(RANLIB) $(LIBNAME).a
-	if test -f $(LIBNAME).cmxs; then \
-	  cp $(LIBNAME).cmxs "$(INSTALL_LIBDIR)/"; fi
-
-partialclean:
-	rm -f *.cm*
-
-clean:: partialclean
-	rm -f *.dll *.so *.a *.lib *.o *.obj
-
-.SUFFIXES: .ml .mli .cmi .cmo .cmx .$(O)
-
-.mli.cmi:
-	$(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmo:
-	$(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmx:
-	$(CAMLOPT) -c $(COMPFLAGS) $(OPTCOMPFLAGS) $<
-
-.c.$(O):
-	$(BYTECC) $(BYTECCCOMPOPTS) $(CFLAGS) -c $<
diff --git a/otherlibs/bigarray/.depend b/otherlibs/bigarray/.depend
index 2f419862..5bf15bc9 100644
--- a/otherlibs/bigarray/.depend
+++ b/otherlibs/bigarray/.depend
@@ -20,6 +20,6 @@ mmap_win32.o: mmap_win32.c bigarray.h ../../byterun/caml/config.h \
   ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \
   ../../byterun/caml/custom.h ../../byterun/caml/fail.h \
   ../../byterun/caml/sys.h ../unix/unixsupport.h
-bigarray.cmi :
 bigarray.cmo : bigarray.cmi
 bigarray.cmx : bigarray.cmi
+bigarray.cmi :
diff --git a/otherlibs/bigarray/Makefile b/otherlibs/bigarray/Makefile
index 5bee2817..7b95b517 100644
--- a/otherlibs/bigarray/Makefile
+++ b/otherlibs/bigarray/Makefile
@@ -13,17 +13,10 @@
 #*                                                                        *
 #**************************************************************************
 
-LIBNAME=bigarray
-EXTRACFLAGS=-I../$(UNIXLIB) -DIN_OCAML_BIGARRAY -DCAML_NAME_SPACE
-EXTRACAMLFLAGS=-I ../$(UNIXLIB)
-COBJS=bigarray_stubs.$(O) mmap_$(UNIX_OR_WIN32).$(O)
-CAMLOBJS=bigarray.cmo
-HEADERS=bigarray.h
-
-include ../Makefile
+include Makefile.shared
 
 depend:
 	$(CC) -MM $(CFLAGS) *.c > .depend
-	$(CAMLRUN) ../../tools/ocamldep *.mli *.ml >> .depend
+	$(CAMLRUN) ../../tools/ocamldep -slash *.mli *.ml >> .depend
 
 include .depend
diff --git a/otherlibs/bigarray/Makefile.nt b/otherlibs/bigarray/Makefile.nt
index 64f4a967..2871177a 100644
--- a/otherlibs/bigarray/Makefile.nt
+++ b/otherlibs/bigarray/Makefile.nt
@@ -13,17 +13,12 @@
 #*                                                                        *
 #**************************************************************************
 
-LIBNAME=bigarray
-EXTRACFLAGS=-I../win32unix -DIN_OCAML_BIGARRAY -DCAML_NAME_SPACE
-EXTRACAMLFLAGS=-I ../win32unix
-COBJS=bigarray_stubs.$(O) mmap_win32.$(O)
-CAMLOBJS=bigarray.cmo
-HEADERS=bigarray.h
+# It would be better to move that to config/Makefile.*
+UNIX_OR_WIN32=win32
 
-include ../Makefile.nt
+include Makefile
 
-depend:
-	$(CC) -MM $(CFLAGS) *.c > .depend
-	$(CAMLRUN) ../../tools/ocamldep *.mli *.ml >> .depend
+.depend.nt: .depend
+	sed -e 's/\.o/.$(O)/g' .depend > .depend.nt
 
-include .depend
+include .depend.nt
diff --git a/otherlibs/bigarray/Makefile.shared b/otherlibs/bigarray/Makefile.shared
new file mode 100644
index 00000000..0d515ed0
--- /dev/null
+++ b/otherlibs/bigarray/Makefile.shared
@@ -0,0 +1,23 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            Xavier Leroy, projet Cristal, INRIA Rocquencourt            *
+#*                                                                        *
+#*   Copyright 1999 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+LIBNAME=bigarray
+EXTRACFLAGS=-I../$(UNIXLIB) -DIN_OCAML_BIGARRAY -DCAML_NAME_SPACE
+EXTRACAMLFLAGS=-I ../$(UNIXLIB)
+COBJS=bigarray_stubs.$(O) mmap_$(UNIX_OR_WIN32).$(O)
+CAMLOBJS=bigarray.cmo
+HEADERS=bigarray.h
+
+include ../Makefile
diff --git a/otherlibs/bigarray/bigarray.ml b/otherlibs/bigarray/bigarray.ml
index 77c200e2..425dde11 100644
--- a/otherlibs/bigarray/bigarray.ml
+++ b/otherlibs/bigarray/bigarray.ml
@@ -110,6 +110,8 @@ module Genarray = struct
 
   external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
   external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
+  external change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
+     = "caml_ba_change_layout"
 
   let size_in_bytes arr =
     (kind_size_in_bytes (kind arr)) * (Array.fold_left ( * ) 1 (dims arr))
@@ -308,6 +310,7 @@ let _ =
   let _ = Array3.get in
   ()
 
+[@@@ocaml.warning "-32"]
 external get1: unit -> unit = "caml_ba_get_1"
 external get2: unit -> unit = "caml_ba_get_2"
 external get3: unit -> unit = "caml_ba_get_3"
diff --git a/otherlibs/bigarray/bigarray.mli b/otherlibs/bigarray/bigarray.mli
index 6b9c6239..c805d518 100644
--- a/otherlibs/bigarray/bigarray.mli
+++ b/otherlibs/bigarray/bigarray.mli
@@ -172,7 +172,9 @@ val char : (char, int8_unsigned_elt) kind
 
 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]. *)
+   an element of type [k].
+
+   @since 4.03.0 *)
 
 (** {6 Array layouts} *)
 
@@ -286,9 +288,23 @@ module Genarray :
   external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
   (** Return the layout of the given big array. *)
 
+  external change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
+      = "caml_ba_change_layout"
+  (** [Genarray.change_layout a layout] returns a bigarray with the
+      specified [layout], sharing the data with [a] (and hence having
+      the same dimensions as [a]). No copying of elements is involved: the
+      new array and the original array share the same storage space.
+      The dimensions are reversed, such that [get v [| a; b |]] in
+      C layout becomes [get v [| b+1; a+1 |]] in Fortran layout.
+
+      @since 4.04.0
+  *)
+
   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}.*)
+    by [a]'s {!kind_size_in_bytes}.
+
+    @since 4.03.0 *)
 
   external get: ('a, 'b, 'c) t -> int array -> 'a = "caml_ba_get_generic"
   (** Read an element of a generic big array.
@@ -502,7 +518,9 @@ module Array1 : sig
 
   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}. *)
+    multiplied by [a]'s {!kind_size_in_bytes}.
+
+    @since 4.03.0 *)
 
   external get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_ref_1"
   (** [Array1.get a x], or alternatively [a.{x}],
@@ -588,7 +606,9 @@ module Array2 :
 
   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}. *)
+    multiplied by [a]'s {!kind_size_in_bytes}.
+
+    @since 4.03.0 *)
 
   external get: ('a, 'b, 'c) t -> int -> int -> 'a = "%caml_ba_ref_2"
   (** [Array2.get a x y], also written [a.{x,y}],
@@ -698,7 +718,9 @@ module Array3 :
 
   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}. *)
+    multiplied by [a]'s {!kind_size_in_bytes}.
+
+    @since 4.03.0 *)
 
   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}],
diff --git a/otherlibs/bigarray/bigarray_stubs.c b/otherlibs/bigarray/bigarray_stubs.c
index 6a885d08..b0619cd7 100644
--- a/otherlibs/bigarray/bigarray_stubs.c
+++ b/otherlibs/bigarray/bigarray_stubs.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include 
 #include 
 #include 
@@ -1078,6 +1080,32 @@ CAMLprim value caml_ba_slice(value vb, value vind)
   #undef b
 }
 
+/* Changing the layout of an array (memory is shared) */
+
+CAMLprim value caml_ba_change_layout(value vb, value vlayout)
+{
+  CAMLparam2 (vb, vlayout);
+  CAMLlocal1 (res);
+  #define b ((struct caml_ba_array *) Caml_ba_array_val(vb))
+  /* if the layout is different, change the flags and reverse the dimensions */
+  if (Caml_ba_layout_val(vlayout) != (b->flags & CAML_BA_LAYOUT_MASK)) {
+    /* change the flags to reflect the new layout */
+    int flags = (b->flags & CAML_BA_KIND_MASK) | Caml_ba_layout_val(vlayout);
+    /* reverse the dimensions */
+    intnat new_dim[CAML_BA_MAX_NUM_DIMS];
+    unsigned int i;
+    for(i = 0; i < b->num_dims; i++) new_dim[i] = b->dim[b->num_dims - i - 1];
+    res = caml_ba_alloc(flags, b->num_dims, b->data, new_dim);
+    caml_ba_update_proxy(b, Caml_ba_array_val(res));
+    CAMLreturn(res);
+  } else {
+  /* otherwise, do nothing */
+  CAMLreturn(vb);
+  }
+  #undef b
+}
+
+
 /* Extracting a sub-array of same number of dimensions */
 
 CAMLprim value caml_ba_sub(value vb, value vofs, value vlen)
diff --git a/otherlibs/bigarray/mmap_unix.c b/otherlibs/bigarray/mmap_unix.c
index 69a83361..f276514c 100644
--- a/otherlibs/bigarray/mmap_unix.c
+++ b/otherlibs/bigarray/mmap_unix.c
@@ -13,9 +13,11 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Needed (under Linux at least) to get pwrite's prototype in unistd.h.
    Must be defined before the first system .h is included. */
-#define _XOPEN_SOURCE 500
+#define _XOPEN_SOURCE 600
 
 #include 
 #include 
diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile
index 8f57196c..35b40f6e 100644
--- a/otherlibs/dynlink/Makefile
+++ b/otherlibs/dynlink/Makefile
@@ -26,8 +26,9 @@ OCAMLC    = $(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib
 OCAMLOPT  = $(CAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib -I $(ROOTDIR)/stdlib
 
 INCLUDES=-I ../../utils -I ../../typing -I ../../bytecomp -I ../../asmcomp
-COMPFLAGS=-w +33..39 -warn-error A -bin-annot -g -safe-string \
-          -I ../../stdlib $(INCLUDES)
+COMPFLAGS=$(INCLUDES) -absname -w +a-4-9-41-42-44-45-48 -bin-annot -g \
+   -I ../../stdlib -warn-error A \
+   -safe-string -strict-sequence -strict-formats
 ifeq "$(FLAMBDA)" "true"
 OPTCOMPFLAGS=-O3
 else
diff --git a/otherlibs/dynlink/dynlink.ml b/otherlibs/dynlink/dynlink.ml
index c9a0a3e1..cbb15194 100644
--- a/otherlibs/dynlink/dynlink.ml
+++ b/otherlibs/dynlink/dynlink.ml
@@ -1,3 +1,4 @@
+#2 "otherlibs/dynlink/dynlink.ml"
 (**************************************************************************)
 (*                                                                        *)
 (*                                 OCaml                                  *)
@@ -92,7 +93,7 @@ let check_consistency file_name cu =
              else
                Consistbl.check_noadd !crc_interfaces name crc file_name)
       cu.cu_imports
-  with Consistbl.Inconsistency(name, user, auth) ->
+  with Consistbl.Inconsistency(name, _user, _auth) ->
          raise(Error(Inconsistent_import name))
      | Consistbl.Not_available(name) ->
          raise(Error(Unavailable_unit name))
diff --git a/otherlibs/dynlink/natdynlink.ml b/otherlibs/dynlink/natdynlink.ml
index 5a70b1d3..685b306b 100644
--- a/otherlibs/dynlink/natdynlink.ml
+++ b/otherlibs/dynlink/natdynlink.ml
@@ -1,3 +1,4 @@
+#2 "otherlibs/dynlink/natdynlink.ml"
 (**************************************************************************)
 (*                                                                        *)
 (*                                 OCaml                                  *)
@@ -120,16 +121,16 @@ let add_check_ifaces allow_ext filename ui ifaces =
            then StrMap.add name (crc,filename) ifaces
            else
              try
-               let (old_crc,old_src) = StrMap.find name ifaces in
+               let (old_crc, _old_src) = StrMap.find name ifaces in
                  if old_crc <> crc
-                 then raise(Error(Inconsistent_import(name)))
+                 then raise(Error(Inconsistent_import name))
                  else ifaces
              with Not_found ->
                if allow_ext then StrMap.add name (crc,filename) ifaces
                else raise (Error(Unavailable_unit name))
     ) ifaces ui.dynu_imports_cmi
 
-let check_implems filename ui implems =
+let check_implems ui implems =
   List.iter
     (fun (name, crco) ->
        match name with
@@ -147,10 +148,10 @@ let check_implems filename ui implems =
          |"Undefined_recursive_module" -> ()
          | _ ->
        try
-         let (old_crc,old_src,state) = StrMap.find name implems in
+         let (old_crc, _old_src, state) = StrMap.find name implems in
            match crco with
              Some crc when old_crc <> crc ->
-               raise(Error(Inconsistent_implementation(name)))
+               raise(Error(Inconsistent_implementation name))
            | _ ->
                match state with
                | Check_inited i ->
@@ -169,7 +170,7 @@ let loadunits filename handle units state =
   let new_implems =
     List.fold_left
       (fun accu ui ->
-         check_implems filename ui accu;
+         check_implems ui accu;
          StrMap.add ui.dynu_name (ui.dynu_crc,filename,Loaded) accu)
       state.implems units in
 
diff --git a/otherlibs/graph/.depend b/otherlibs/graph/.depend
index 06ba20b8..ada82fd6 100644
--- a/otherlibs/graph/.depend
+++ b/otherlibs/graph/.depend
@@ -21,10 +21,7 @@ dump_img.o: dump_img.c libgraph.h \
   ../../byterun/caml/mlvalues.h ../../byterun/caml/compatibility.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h image.h \
-  ../../byterun/caml/alloc.h ../../byterun/caml/memory.h \
-  ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \
-  ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \
-  ../../byterun/caml/address_class.h
+  ../../byterun/caml/alloc.h ../../byterun/caml/memory.h
 events.o: events.c libgraph.h \
   \
   \
@@ -40,9 +37,7 @@ fill.o: fill.c libgraph.h \
   ../../byterun/caml/mlvalues.h ../../byterun/caml/compatibility.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h
+  ../../byterun/caml/memory.h
 image.o: image.c libgraph.h \
   \
   \
@@ -58,9 +53,7 @@ make_img.o: make_img.c libgraph.h \
   ../../byterun/caml/mlvalues.h ../../byterun/caml/compatibility.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h image.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h
+  ../../byterun/caml/memory.h
 open.o: open.c libgraph.h \
   \
   \
@@ -69,10 +62,7 @@ open.o: open.c libgraph.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/callback.h \
-  ../../byterun/caml/fail.h ../../byterun/caml/memory.h \
-  ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \
-  ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \
-  ../../byterun/caml/address_class.h
+  ../../byterun/caml/fail.h ../../byterun/caml/memory.h
 point_col.o: point_col.c libgraph.h \
   \
   \
@@ -102,9 +92,9 @@ text.o: text.c libgraph.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h
-graphics.cmi :
-graphicsX11.cmi :
 graphics.cmo : graphics.cmi
 graphics.cmx : graphics.cmi
+graphics.cmi :
 graphicsX11.cmo : graphics.cmi graphicsX11.cmi
 graphicsX11.cmx : graphics.cmx graphicsX11.cmi
+graphicsX11.cmi :
diff --git a/otherlibs/graph/Makefile b/otherlibs/graph/Makefile
index 4e844d74..68875543 100644
--- a/otherlibs/graph/Makefile
+++ b/otherlibs/graph/Makefile
@@ -29,6 +29,6 @@ include ../Makefile
 
 depend:
 	$(CC) -MM $(CFLAGS) *.c | sed -e 's, /[^ ]*\.h,,g' > .depend
-	$(CAMLRUN) ../../tools/ocamldep *.mli *.ml >> .depend
+	$(CAMLRUN) ../../tools/ocamldep -slash *.mli *.ml >> .depend
 
 include .depend
diff --git a/otherlibs/graph/events.c b/otherlibs/graph/events.c
index 4a685f04..164c3601 100644
--- a/otherlibs/graph/events.c
+++ b/otherlibs/graph/events.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include 
 #include "libgraph.h"
 #include 
diff --git a/otherlibs/graph/graphics.ml b/otherlibs/graph/graphics.ml
index 84cea7d5..36328986 100644
--- a/otherlibs/graph/graphics.ml
+++ b/otherlibs/graph/graphics.ml
@@ -231,8 +231,7 @@ let loop_at_exit events handler =
 external sound : int -> int -> unit = "caml_gr_sound"
 
 (* Splines *)
-let add (x1, y1) (x2, y2) = (x1 +. x2, y1 +. y2)
-and sub (x1, y1) (x2, y2) = (x1 -. x2, y1 -. y2)
+let sub (x1, y1) (x2, y2) = (x1 -. x2, y1 -. y2)
 and middle (x1, y1) (x2, y2) = ((x1 +. x2) /. 2.0,  (y1 +. y2) /. 2.0)
 and area (x1, y1) (x2, y2) = abs_float (x1 *. y2 -. x2 *. y1)
 and norm (x1, y1) = sqrt (x1 *. x1 +. y1 *. y1);;
diff --git a/otherlibs/num/.depend b/otherlibs/num/.depend
index 7e8a3999..906bca5e 100644
--- a/otherlibs/num/.depend
+++ b/otherlibs/num/.depend
@@ -18,24 +18,24 @@ nat_stubs.o: nat_stubs.c ../../byterun/caml/alloc.h \
   ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \
   ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \
   ../../byterun/caml/address_class.h bng.h nat.h
-arith_flags.cmi :
-arith_status.cmi :
-big_int.cmi : nat.cmi
-int_misc.cmi :
-nat.cmi :
-num.cmi : ratio.cmi nat.cmi big_int.cmi
-ratio.cmi : nat.cmi big_int.cmi
 arith_flags.cmo : arith_flags.cmi
 arith_flags.cmx : arith_flags.cmi
+arith_flags.cmi :
 arith_status.cmo : arith_flags.cmi arith_status.cmi
 arith_status.cmx : arith_flags.cmx arith_status.cmi
+arith_status.cmi :
 big_int.cmo : nat.cmi int_misc.cmi big_int.cmi
 big_int.cmx : nat.cmx int_misc.cmx big_int.cmi
+big_int.cmi : nat.cmi
 int_misc.cmo : int_misc.cmi
 int_misc.cmx : int_misc.cmi
+int_misc.cmi :
 nat.cmo : int_misc.cmi nat.cmi
 nat.cmx : int_misc.cmx nat.cmi
+nat.cmi :
 num.cmo : ratio.cmi nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi num.cmi
 num.cmx : ratio.cmx nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx num.cmi
+num.cmi : ratio.cmi nat.cmi big_int.cmi
 ratio.cmo : nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi ratio.cmi
 ratio.cmx : nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx ratio.cmi
+ratio.cmi : nat.cmi big_int.cmi
diff --git a/otherlibs/num/Makefile b/otherlibs/num/Makefile
index 344789b1..7b95b517 100644
--- a/otherlibs/num/Makefile
+++ b/otherlibs/num/Makefile
@@ -13,25 +13,10 @@
 #*                                                                        *
 #**************************************************************************
 
-# Makefile for the "num" (exact rational arithmetic) library
-
-LIBNAME=nums
-EXTRACFLAGS=-DBNG_ARCH_$(BNG_ARCH) -DBNG_ASM_LEVEL=$(BNG_ASM_LEVEL)
-CAMLOBJS=int_misc.cmo nat.cmo big_int.cmo arith_flags.cmo \
-  ratio.cmo num.cmo arith_status.cmo
-CMIFILES=big_int.cmi nat.cmi num.cmi ratio.cmi arith_status.cmi
-COBJS=bng.$(O) nat_stubs.$(O)
-
-include ../Makefile
-
-clean::
-	rm -f *~
-
-bng.$(O): bng.h bng_digit.c \
-       bng_amd64.c bng_ia32.c bng_ppc.c bng_sparc.c
+include Makefile.shared
 
 depend:
 	$(CC) -MM $(CFLAGS) *.c > .depend
-	$(CAMLRUN) ../../tools/ocamldep *.mli *.ml >> .depend
+	$(CAMLRUN) ../../tools/ocamldep -slash *.mli *.ml >> .depend
 
 include .depend
diff --git a/otherlibs/num/Makefile.nt b/otherlibs/num/Makefile.nt
index 2b0fab0a..1c47f07b 100644
--- a/otherlibs/num/Makefile.nt
+++ b/otherlibs/num/Makefile.nt
@@ -13,22 +13,7 @@
 #*                                                                        *
 #**************************************************************************
 
-# Makefile for the "num" (exact rational arithmetic) library
-
-LIBNAME=nums
-EXTRACFLAGS=-DBNG_ARCH_$(BNG_ARCH) -DBNG_ASM_LEVEL=$(BNG_ASM_LEVEL)
-CAMLOBJS=int_misc.cmo nat.cmo big_int.cmo arith_flags.cmo \
-  ratio.cmo num.cmo arith_status.cmo
-CMIFILES=big_int.cmi nat.cmi num.cmi ratio.cmi arith_status.cmi
-COBJS=bng.$(O) nat_stubs.$(O)
-
-include ../Makefile.nt
-
-clean::
-	rm -f *~
-
-bng.$(O): bng.h bng_digit.c \
-       bng_amd64.c bng_ia32.c bng_ppc.c bng_sparc.c
+include Makefile.shared
 
 depend:
 	sed -e 's/\.o/.$(O)/g' .depend > .depend.nt
diff --git a/otherlibs/num/Makefile.shared b/otherlibs/num/Makefile.shared
new file mode 100644
index 00000000..1487786e
--- /dev/null
+++ b/otherlibs/num/Makefile.shared
@@ -0,0 +1,37 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            Xavier Leroy, projet Cristal, INRIA Rocquencourt            *
+#*                                                                        *
+#*   Copyright 1999 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# Makefile for the "num" (exact rational arithmetic) library
+
+LIBNAME=nums
+EXTRACFLAGS=-DBNG_ARCH_$(BNG_ARCH) -DBNG_ASM_LEVEL=$(BNG_ASM_LEVEL)
+CAMLOBJS=int_misc.cmo nat.cmo big_int.cmo arith_flags.cmo \
+  ratio.cmo num.cmo arith_status.cmo
+CMIFILES=big_int.cmi nat.cmi num.cmi ratio.cmi arith_status.cmi
+COBJS=bng.$(O) nat_stubs.$(O)
+
+include ../Makefile
+
+clean::
+	rm -f *~
+
+bng.$(O): bng.h bng_digit.c \
+       bng_amd64.c bng_ia32.c bng_ppc.c bng_sparc.c
+
+depend:
+	$(CC) -MM $(CFLAGS) *.c > .depend
+	$(CAMLRUN) ../../tools/ocamldep -slash *.mli *.ml >> .depend
+
+include .depend
diff --git a/otherlibs/num/arith_status.mli b/otherlibs/num/arith_status.mli
index 9bbc7828..ba604347 100644
--- a/otherlibs/num/arith_status.mli
+++ b/otherlibs/num/arith_status.mli
@@ -19,7 +19,7 @@ val arith_status: unit -> unit
         (** Print the current status of the arithmetic flags. *)
 
 val get_error_when_null_denominator : unit -> bool
-        (** See {!Arith_status.set_error_when_null_denominator}.*)
+(** See {!Arith_status.set_error_when_null_denominator}.*)
 
 val set_error_when_null_denominator : bool -> unit
         (** Get or set the flag [null_denominator]. When on, attempting to
@@ -28,7 +28,7 @@ val set_error_when_null_denominator : bool -> unit
            Initially: on. *)
 
 val get_normalize_ratio : unit -> bool
-        (** See {!Arith_status.set_normalize_ratio}.*)
+(** See {!Arith_status.set_normalize_ratio}.*)
 
 val set_normalize_ratio : bool -> unit
         (** Get or set the flag [normalize_ratio]. When on, rational
@@ -37,7 +37,7 @@ val set_normalize_ratio : bool -> unit
            Initially: off. *)
 
 val get_normalize_ratio_when_printing : unit -> bool
-        (** See {!Arith_status.set_normalize_ratio_when_printing}.*)
+(** See {!Arith_status.set_normalize_ratio_when_printing}.*)
 
 val set_normalize_ratio_when_printing : bool -> unit
         (** Get or set the flag [normalize_ratio_when_printing].
@@ -46,7 +46,7 @@ val set_normalize_ratio_when_printing : bool -> unit
            Initially: on. *)
 
 val get_approx_printing : unit -> bool
-        (** See {!Arith_status.set_approx_printing}.*)
+(** See {!Arith_status.set_approx_printing}.*)
 
 val set_approx_printing : bool -> unit
         (** Get or set the flag [approx_printing].
@@ -55,7 +55,7 @@ val set_approx_printing : bool -> unit
            Initially: off. *)
 
 val get_floating_precision : unit -> int
-        (** See {!Arith_status.set_floating_precision}.*)
+(** See {!Arith_status.set_floating_precision}.*)
 
 val set_floating_precision : int -> unit
         (** Get or set the parameter [floating_precision].
diff --git a/otherlibs/num/big_int.ml b/otherlibs/num/big_int.ml
index 6fb030d5..efe376ca 100644
--- a/otherlibs/num/big_int.ml
+++ b/otherlibs/num/big_int.ml
@@ -464,7 +464,7 @@ let power_base_nat base nat off len =
   if base = 0 then nat_of_int 0 else
   if is_zero_nat nat off len || base = 1 then nat_of_int 1 else
   let power_base = make_nat (succ length_of_digit) in
-  let (pmax, pint) = make_power_base base power_base in
+  let (pmax, _pint) = make_power_base base power_base in
   let (n, rem) =
       let (x, y) = quomod_big_int (sys_big_int_of_nat nat off len)
                                   (big_int_of_int (succ pmax)) in
@@ -662,10 +662,10 @@ let approx_big_int prec bi =
     Bytes.unsafe_of_string
       (string_of_big_int (div_big_int bi (power_int_positive_int 10 n)))
   in
-  let (sign, off, len) =
+  let (sign, off) =
     if Bytes.get s 0 = '-'
-       then ("-", 1, succ prec)
-       else ("", 0, prec) in
+       then ("-", 1)
+       else ("", 0) in
   if (round_futur_last_digit s off (succ prec))
        then (sign^"1."^(String.make prec '0')^"e"^
              (string_of_int (n + 1 - off + Bytes.length s)))
diff --git a/otherlibs/num/big_int.mli b/otherlibs/num/big_int.mli
index 011b83c3..f5b2800f 100644
--- a/otherlibs/num/big_int.mli
+++ b/otherlibs/num/big_int.mli
@@ -24,7 +24,7 @@ type big_int
         (** The type of big integers. *)
 
 val zero_big_int : big_int
-        (** The big integer [0]. *)
+(** The big integer [0]. *)
 
 val unit_big_int : big_int
         (** The big integer [1]. *)
@@ -32,39 +32,39 @@ val unit_big_int : big_int
 (** {6 Arithmetic operations} *)
 
 val minus_big_int : big_int -> big_int
-        (** Unary negation. *)
+(** Unary negation. *)
 
 val abs_big_int : big_int -> big_int
-        (** Absolute value. *)
+(** Absolute value. *)
 
 val add_big_int : big_int -> big_int -> big_int
-        (** Addition. *)
+(** Addition. *)
 
 val succ_big_int : big_int -> big_int
-        (** Successor (add 1). *)
+(** Successor (add 1). *)
 
 val add_int_big_int : int -> big_int -> big_int
-        (** Addition of a small integer to a big integer. *)
+(** Addition of a small integer to a big integer. *)
 
 val sub_big_int : big_int -> big_int -> big_int
-        (** Subtraction. *)
+(** Subtraction. *)
 
 val pred_big_int : big_int -> big_int
-        (** Predecessor (subtract 1). *)
+(** Predecessor (subtract 1). *)
 
 val mult_big_int : big_int -> big_int -> big_int
-        (** Multiplication of two big integers. *)
+(** Multiplication of two big integers. *)
 
 val mult_int_big_int : int -> big_int -> big_int
-        (** Multiplication of a big integer by a small integer *)
+(** Multiplication of a big integer by a small integer *)
 
 val square_big_int: big_int -> big_int
-        (** Return the square of the given big integer *)
+(** Return the square of the given big integer *)
 
 val sqrt_big_int: big_int -> big_int
         (** [sqrt_big_int a] returns the integer square root of [a],
            that is, the largest big integer [r] such that [r * r <= a].
-           Raise [Invalid_argument] if [a] is negative. *)
+            Raise [Invalid_argument] if [a] is negative. *)
 
 val quomod_big_int : big_int -> big_int -> big_int * big_int
         (** Euclidean division of two big integers.
@@ -72,18 +72,18 @@ val quomod_big_int : big_int -> big_int -> big_int * big_int
            the second part is the remainder.
            Writing [(q,r) = quomod_big_int a b], we have
            [a = q * b + r] and [0 <= r < |b|].
-           Raise [Division_by_zero] if the divisor is zero. *)
+            Raise [Division_by_zero] if the divisor is zero. *)
 
 val div_big_int : big_int -> big_int -> big_int
         (** Euclidean quotient of two big integers.
-           This is the first result [q] of [quomod_big_int] (see above). *)
+            This is the first result [q] of [quomod_big_int] (see above). *)
 
 val mod_big_int : big_int -> big_int -> big_int
         (** Euclidean modulus of two big integers.
-           This is the second result [r] of [quomod_big_int] (see above). *)
+            This is the second result [r] of [quomod_big_int] (see above). *)
 
 val gcd_big_int : big_int -> big_int -> big_int
-        (** Greatest common divisor of two big integers. *)
+(** Greatest common divisor of two big integers. *)
 
 val power_int_positive_int: int -> int -> big_int
 val power_big_int_positive_int: big_int -> int -> big_int
@@ -99,41 +99,43 @@ val power_big_int_positive_big_int: big_int -> big_int -> big_int
 
 val sign_big_int : big_int -> int
         (** Return [0] if the given big integer is zero,
-           [1] if it is positive, and [-1] if it is negative. *)
+            [1] if it is positive, and [-1] if it is negative. *)
 
 val compare_big_int : big_int -> big_int -> int
         (** [compare_big_int a b] returns [0] if [a] and [b] are equal,
            [1] if [a] is greater than [b], and [-1] if [a] is smaller
-           than [b]. *)
+            than [b]. *)
 
 val eq_big_int : big_int -> big_int -> bool
 val le_big_int : big_int -> big_int -> bool
 val ge_big_int : big_int -> big_int -> bool
 val lt_big_int : big_int -> big_int -> bool
 val gt_big_int : big_int -> big_int -> bool
-        (** Usual boolean comparisons between two big integers. *)
+(** Usual boolean comparisons between two big integers. *)
 
 val max_big_int : big_int -> big_int -> big_int
-        (** Return the greater of its two arguments. *)
+(** Return the greater of its two arguments. *)
 
 val min_big_int : big_int -> big_int -> big_int
-        (** Return the smaller of its two arguments. *)
+(** Return the smaller of its two arguments. *)
 
 val num_digits_big_int : big_int -> int
         (** Return the number of machine words used to store the
-           given big integer.  *)
+            given big integer.  *)
 
 val num_bits_big_int : big_int -> int
         (** Return the number of significant bits in the absolute
             value of the given big integer.  [num_bits_big_int a]
             returns 0 if [a] is 0; otherwise it returns a positive
-            integer [n] such that [2^(n-1) <= |a| < 2^n]. *)
+            integer [n] such that [2^(n-1) <= |a| < 2^n].
+
+            @since 4.03.0 *)
 
 (** {6 Conversions to and from strings} *)
 
 val string_of_big_int : big_int -> string
         (** Return the string representation of the given big integer,
-           in decimal (base 10). *)
+            in decimal (base 10). *)
 
 val big_int_of_string : string -> big_int
         (** Convert a string to a big integer, in decimal.
@@ -143,7 +145,7 @@ val big_int_of_string : string -> big_int
 (** {6 Conversions to and from other numerical types} *)
 
 val big_int_of_int : int -> big_int
-        (** Convert a small integer to a big integer. *)
+(** Convert a small integer to a big integer. *)
 
 val is_int_big_int : big_int -> bool
         (** Test whether the given big integer is small enough to
@@ -152,7 +154,7 @@ val is_int_big_int : big_int -> bool
            [is_int_big_int a] returns [true] if and only if
            [a] is between 2{^30} and 2{^30}-1.  On a 64-bit platform,
            [is_int_big_int a] returns [true] if and only if
-           [a] is between -2{^62} and 2{^62}-1. *)
+            [a] is between -2{^62} and 2{^62}-1. *)
 
 val int_of_big_int : big_int -> int
         (** Convert a big integer to a small integer (type [int]).
@@ -160,13 +162,13 @@ val int_of_big_int : big_int -> int
            is not representable as a small integer. *)
 
 val big_int_of_int32 : int32 -> big_int
-        (** Convert a 32-bit integer to a big integer. *)
+(** Convert a 32-bit integer to a big integer. *)
 
 val big_int_of_nativeint : nativeint -> big_int
-        (** Convert a native integer to a big integer. *)
+(** Convert a native integer to a big integer. *)
 
 val big_int_of_int64 : int64 -> big_int
-        (** Convert a 64-bit integer to a big integer. *)
+(** Convert a 64-bit integer to a big integer. *)
 
 val int32_of_big_int : big_int -> int32
         (** Convert a big integer to a 32-bit integer.
@@ -226,10 +228,13 @@ val extract_big_int : big_int -> int -> int -> big_int
 (**/**)
 
 (** {6 For internal use} *)
+
 val nat_of_big_int : big_int -> nat
 val big_int_of_nat : nat -> big_int
 val base_power_big_int: int -> int -> big_int -> big_int
 val sys_big_int_of_string: string -> int -> int -> big_int
 val round_futur_last_digit : bytes -> int -> int -> bool
 val approx_big_int: int -> big_int -> string
+
 val round_big_int_to_float: big_int -> bool -> float
+(* @since 4.03.0 *)
diff --git a/otherlibs/num/nat.ml b/otherlibs/num/nat.ml
index c0edabd9..c7a26698 100644
--- a/otherlibs/num/nat.ml
+++ b/otherlibs/num/nat.ml
@@ -155,6 +155,7 @@ let square_nat nat1 off1 len1 nat2 off2 len2 =
   !c
 ***)
 
+(*
 let gcd_int_nat i nat off len =
   if i = 0 then 1 else
   if is_nat_int nat off len then begin
@@ -170,6 +171,7 @@ let gcd_int_nat i nat off len =
     set_digit_nat nat off (gcd_int (nth_digit_nat remainder 0) i);
     0
   end
+*)
 
 let exchange r1 r2 =
   let old1 = !r1 in r1 := !r2; r2 := old1
@@ -335,8 +337,6 @@ let string_of_digit nat =
 
 *******)
 
-let digits = "0123456789ABCDEF"
-
 (*
    make_power_base affecte power_base des puissances successives de base a
    partir de la puissance 1-ieme.
@@ -363,11 +363,14 @@ let make_power_base base power_base =
    while !j < !i - 1 && is_digit_int power_base !j do incr j done;
   (!i - 2, !j)
 
+(*
 (*
    int_to_string places the representation of the integer int in base 'base'
    in the string s by starting from the end position pos and going towards
    the start, for 'times' places and updates the value of pos.
 *)
+let digits = "0123456789ABCDEF"
+
 let int_to_string int s pos_ref base times =
   let i = ref int
   and j = ref times in
@@ -377,6 +380,7 @@ let int_to_string int s pos_ref base times =
         decr j;
         i := !i / base
      done
+*)
 
 let power_base_int base i =
   if i = 0 || base = 1 then
@@ -387,7 +391,7 @@ let power_base_int base i =
     invalid_arg "power_base_int"
   else begin
          let power_base = make_nat (succ length_of_digit) in
-         let (pmax, pint) = make_power_base base power_base in
+         let (pmax, _pint) = make_power_base base power_base in
          let n = i / (succ pmax)
          and rem = i mod (succ pmax) in
            if n > 0 then begin
diff --git a/otherlibs/num/nat_stubs.c b/otherlibs/num/nat_stubs.c
index 005aaffe..f85d7c13 100644
--- a/otherlibs/num/nat_stubs.c
+++ b/otherlibs/num/nat_stubs.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include "caml/alloc.h"
 #include "caml/config.h"
 #include "caml/custom.h"
diff --git a/otherlibs/num/num.ml b/otherlibs/num/num.ml
index 0a85951c..d3d76eac 100644
--- a/otherlibs/num/num.ml
+++ b/otherlibs/num/num.ml
@@ -31,14 +31,6 @@ let num_of_big_int bi =
  then Int (int_of_big_int bi)
  else Big_int bi
 
-let numerator_num = function
-  Ratio r -> ignore (normalize_ratio r); num_of_big_int (numerator_ratio r)
-| n -> n
-
-let denominator_num = function
-  Ratio r -> ignore (normalize_ratio r); num_of_big_int (denominator_ratio r)
-| n -> Int 1
-
 let normalize_num = function
   Int i -> Int i
 | Big_int bi -> num_of_big_int bi
@@ -158,8 +150,8 @@ let div_num n1 n2 =
 let ( // ) = div_num
 
 let floor_num = function
-  Int i as n -> n
-| Big_int bi as n -> n
+  Int _ as n -> n
+| Big_int _ as n -> n
 | Ratio r -> num_of_big_int (floor_ratio r)
 
 (* Coercion with ratio type *)
@@ -284,18 +276,18 @@ let is_integer_num = function
 
 (* integer_num, floor_num, round_num, ceiling_num rendent des nums *)
 let integer_num = function
-  Int i as n -> n
-| Big_int bi as n -> n
+  Int _ as n -> n
+| Big_int _ as n -> n
 | Ratio r -> num_of_big_int (integer_ratio r)
 
 and round_num = function
-  Int i as n -> n
-| Big_int bi as n -> n
+  Int _ as n -> n
+| Big_int _ as n -> n
 | Ratio r -> num_of_big_int (round_ratio r)
 
 and ceiling_num = function
-  Int i as n -> n
-| Big_int bi as n -> n
+  Int _ as n -> n
+| Big_int _ as n -> n
 | Ratio r -> num_of_big_int (ceiling_ratio r)
 
 (* Comparisons on nums *)
diff --git a/otherlibs/raw_spacetime_lib/.depend b/otherlibs/raw_spacetime_lib/.depend
new file mode 100644
index 00000000..ddc792f7
--- /dev/null
+++ b/otherlibs/raw_spacetime_lib/.depend
@@ -0,0 +1,42 @@
+aProf.cmi :
+camlinternalAProf.cmi :
+aProf.cmo : aProf.cmi
+aProf.cmx : aProf.cmi
+camlinternalAProf.cmo : camlinternalAProf.cmi
+camlinternalAProf.cmx : camlinternalAProf.cmi
+aProf.cmi :
+camlinternalAProf.cmi :
+aProf.cmo : camlinternalAProf.cmi aProf.cmi
+aProf.cmx : camlinternalAProf.cmx aProf.cmi
+camlinternalAProf.cmo : camlinternalAProf.cmi
+camlinternalAProf.cmx : camlinternalAProf.cmi
+aProf.cmi :
+rawAProf.cmi :
+aProf.cmo : aProf.cmi
+aProf.cmx : aProf.cmi
+rawAProf.cmo : rawAProf.cmi
+rawAProf.cmx : rawAProf.cmi
+aProf.cmo : rawAProf.cmi aProf.cmi
+aProf.cmx : rawAProf.cmx aProf.cmi
+aProf.cmi :
+rawAProf.cmo : rawAProf.cmi
+rawAProf.cmx : rawAProf.cmi
+rawAProf.cmi :
+raw_spacetime_lib.cmo : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmx : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmi :
+spacetime_lib.cmo : raw_spacetime_lib.cmi spacetime_lib.cmi
+spacetime_lib.cmx : raw_spacetime_lib.cmx spacetime_lib.cmi
+spacetime_lib.cmi :
+raw_spacetime_lib.cmo : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmx : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmi :
+raw_spacetime_lib.cmo : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmx : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmi :
+raw_spacetime_lib.cmo : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmx : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmi :
+raw_spacetime_lib.cmo : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmx : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmi :
diff --git a/otherlibs/raw_spacetime_lib/Makefile b/otherlibs/raw_spacetime_lib/Makefile
new file mode 100644
index 00000000..3dd7a322
--- /dev/null
+++ b/otherlibs/raw_spacetime_lib/Makefile
@@ -0,0 +1,25 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*           Xavier Leroy, projet Cristal, INRIA Rocquencourt             *
+#*                                                                        *
+#*   Copyright 1999 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# Common Makefile for otherlibs on the Unix ports
+
+CAMLC=$(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib
+CAMLOPT=$(CAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib \
+        -I $(ROOTDIR)/stdlib
+CFLAGS=-I$(ROOTDIR)/byterun $(SHAREDCCCOMPOPTS) $(EXTRACFLAGS)
+
+include Makefile.shared
+# Note .. is the current directory (this makefile is included from
+# a subdirectory)
diff --git a/otherlibs/raw_spacetime_lib/Makefile.nt b/otherlibs/raw_spacetime_lib/Makefile.nt
new file mode 100644
index 00000000..f8fdaccd
--- /dev/null
+++ b/otherlibs/raw_spacetime_lib/Makefile.nt
@@ -0,0 +1,23 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*           Xavier Leroy, projet Cristal, INRIA Rocquencourt             *
+#*                                                                        *
+#*   Copyright 1999 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# Common Makefile for otherlibs on the Win32/MinGW ports
+
+include Makefile
+
+# The Unix version now works fine under Windows
+
+# Note .. is the current directory (this makefile is included from
+# a subdirectory)
diff --git a/otherlibs/raw_spacetime_lib/Makefile.shared b/otherlibs/raw_spacetime_lib/Makefile.shared
new file mode 100644
index 00000000..a43fe4d2
--- /dev/null
+++ b/otherlibs/raw_spacetime_lib/Makefile.shared
@@ -0,0 +1,74 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*           Mark Shinwell and Leo White, Jane Street Europe              *
+#*                                                                        *
+#*   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.          *
+#*                                                                        *
+#**************************************************************************
+
+# Makefile for Raw_spacetime_lib
+
+ROOTDIR=../..
+include $(ROOTDIR)/config/Makefile
+CAMLRUN ?= $(ROOTDIR)/boot/ocamlrun
+
+LIBNAME=raw_spacetime_lib
+CAMLOBJS=raw_spacetime_lib.cmo
+
+CC=$(BYTECC)
+COMPFLAGS=-w +33..39 -warn-error A -bin-annot -g -safe-string $(EXTRACAMLFLAGS)
+
+CMIFILES=$(CAMLOBJS:.cmo=.cmi)
+CAMLOBJS_NAT=$(CAMLOBJS:.cmo=.cmx)
+
+all: $(LIBNAME).cma $(CMIFILES)
+
+allopt: $(LIBNAME).cmxa $(LIBNAME).$(CMXS) $(CMIFILES)
+
+$(LIBNAME).cma: $(CAMLOBJS)
+	$(CAMLC) -a -o $(LIBNAME).cma -linkall $(CAMLOBJS)
+
+$(LIBNAME).cmxa: $(CAMLOBJS_NAT)
+	$(CAMLOPT) -a -o $(LIBNAME).cmxa -linkall $(CAMLOBJS_NAT)
+
+$(LIBNAME).cmxs: $(LIBNAME).cmxa
+	$(CAMLOPT) -shared -o $(LIBNAME).cmxs -I . $(LIBNAME).cmxa
+
+INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
+
+install::
+	cp $(LIBNAME).cma $(CMIFILES) $(CMIFILES:.cmi=.mli) $(INSTALL_LIBDIR)
+
+installopt:
+	cp $(CAMLOBJS_NAT) $(LIBNAME).cmxa $(LIBNAME).$(A) $(INSTALL_LIBDIR)/
+	if test -f $(LIBNAME).cmxs; then \
+	  cp $(LIBNAME).cmxs $(INSTALL_LIBDIR)/; \
+	fi
+
+partialclean:
+	rm -f *.cm*
+
+clean:: partialclean
+	rm -f *.a *.o
+
+.SUFFIXES: .ml .mli .cmi .cmo .cmx
+
+.mli.cmi:
+	$(CAMLC) -c $(COMPFLAGS) $<
+
+.ml.cmo:
+	$(CAMLC) -c $(COMPFLAGS) $<
+
+.ml.cmx:
+	$(CAMLOPT) -c $(COMPFLAGS) $<
+
+depend:
+	$(CAMLRUN) ../../tools/ocamldep *.mli *.ml >> .depend
+
+include .depend
diff --git a/otherlibs/raw_spacetime_lib/raw_spacetime_lib.ml b/otherlibs/raw_spacetime_lib/raw_spacetime_lib.ml
new file mode 100644
index 00000000..e1010a9f
--- /dev/null
+++ b/otherlibs/raw_spacetime_lib/raw_spacetime_lib.ml
@@ -0,0 +1,644 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   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.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+module Gc_stats : sig
+  type t
+
+  val minor_words : t -> int
+  val promoted_words : t -> int
+  val major_words : t -> int
+  val minor_collections : t -> int
+  val major_collections : t -> int
+  val heap_words : t -> int
+  val heap_chunks : t -> int
+  val compactions : t -> int
+  val top_heap_words : t -> int
+end = struct
+  type t = {
+    minor_words : int;
+    promoted_words : int;
+    major_words : int;
+    minor_collections : int;
+    major_collections : int;
+    heap_words : int;
+    heap_chunks : int;
+    compactions : int;
+    top_heap_words : int;
+  }
+
+  let minor_words t = t.minor_words
+  let promoted_words t = t.promoted_words
+  let major_words t = t.major_words
+  let minor_collections t = t.minor_collections
+  let major_collections t = t.major_collections
+  let heap_words t = t.heap_words
+  let heap_chunks t = t.heap_chunks
+  let compactions t = t.compactions
+  let top_heap_words t = t.top_heap_words
+end
+
+module Program_counter = struct
+  module OCaml = struct
+    type t = Int64.t
+
+    let to_int64 t = t
+  end
+
+  module Foreign = struct
+    type t = Int64.t
+
+    let to_int64 t = t
+  end
+end
+
+module Function_identifier = struct
+  type t = Int64.t
+
+  let to_int64 t = t
+end
+
+module Function_entry_point = struct
+  type t = Int64.t
+
+  let to_int64 t = t
+end
+
+module Int64_map = Map.Make (Int64)
+
+module Frame_table = struct
+  type raw = (Int64.t * (Printexc.Slot.t list)) list
+
+  type t = Printexc.Slot.t list Int64_map.t
+
+  let demarshal chn : t =
+    let raw : raw = Marshal.from_channel chn in
+    List.fold_left (fun map (pc, rev_location_list) ->
+        Int64_map.add pc (List.rev rev_location_list) map)
+      Int64_map.empty
+      raw
+
+  let find_exn = Int64_map.find
+end
+
+module Shape_table = struct
+  type part_of_shape =
+    | Direct_call of { call_site : Int64.t; callee : Int64.t; }
+    | Indirect_call of Int64.t
+    | Allocation_point of Int64.t
+
+  let _ = Direct_call { call_site = 0L; callee = 0L; }
+  let _ = Indirect_call 0L
+  let _ = Allocation_point 0L
+
+  let part_of_shape_size = function
+    | Direct_call _
+    | Indirect_call _ -> 1
+    | Allocation_point _ -> 3
+
+  type raw = (Int64.t * (part_of_shape list)) list
+
+  type t = part_of_shape list Int64_map.t
+
+  let demarshal chn : t =
+    let raw : raw = Marshal.from_channel chn in
+    List.fold_left (fun map (key, data) -> Int64_map.add key data map)
+      Int64_map.empty
+      raw
+
+  let find_exn = Int64_map.find
+end
+
+module Annotation = struct
+  type t = int
+
+  let to_int t = t
+end
+
+module Trace = struct
+  type node
+  type ocaml_node
+  type foreign_node
+  type uninstrumented_node
+
+  type t = node option
+
+  (* This function unmarshals into malloc blocks, which mean that we
+     obtain a straightforward means of writing [compare] on [node]s. *)
+  external unmarshal : in_channel -> 'a
+    = "caml_spacetime_only_works_for_native_code"
+      "caml_spacetime_unmarshal_trie"
+
+  let unmarshal in_channel =
+    let trace = unmarshal in_channel in
+    if trace = () then
+      None
+    else
+      Some ((Obj.magic trace) : node)
+
+  let node_is_null (node : node) =
+    ((Obj.magic node) : unit) == ()
+
+  let foreign_node_is_null (node : foreign_node) =
+    ((Obj.magic node) : unit) == ()
+
+  external node_num_header_words : unit -> int
+    = "caml_spacetime_only_works_for_native_code"
+      "caml_spacetime_node_num_header_words" "noalloc"
+
+  let num_header_words = lazy (node_num_header_words ())
+
+  module OCaml = struct
+    type field_iterator = {
+      node : ocaml_node;
+      offset : int;
+      part_of_shape : Shape_table.part_of_shape;
+      remaining_layout : Shape_table.part_of_shape list;
+      shape_table : Shape_table.t;
+    }
+
+    module Allocation_point = struct
+      type t = field_iterator
+
+      let program_counter t =
+        match t.part_of_shape with
+        | Shape_table.Allocation_point call_site -> call_site
+        | _ -> assert false
+
+      external annotation : ocaml_node -> int -> Annotation.t
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_ocaml_allocation_point_annotation"
+          "noalloc"
+
+      let annotation t = annotation t.node t.offset
+
+      external count : ocaml_node -> int -> int
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_ocaml_allocation_point_count"
+          "noalloc"
+
+      let num_words_including_headers t = count t.node t.offset
+    end
+
+    module Direct_call_point = struct
+      type _ t = field_iterator
+
+      let call_site t =
+        match t.part_of_shape with
+        | Shape_table.Direct_call { call_site; _ } -> call_site
+        | _ -> assert false
+
+      let callee t =
+        match t.part_of_shape with
+        | Shape_table.Direct_call { callee; _ } -> callee
+        | _ -> assert false
+
+      external callee_node : ocaml_node -> int -> 'target
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_ocaml_direct_call_point_callee_node"
+
+      let callee_node (type target) (t : target t) : target =
+        callee_node t.node t.offset
+    end
+
+    module Indirect_call_point = struct
+      type t = field_iterator
+
+      let call_site t =
+        match t.part_of_shape with
+        | Shape_table.Indirect_call call_site -> call_site
+        | _ -> assert false
+
+      module Callee = struct
+        (* CR-soon mshinwell: we should think about the names again.  This is
+           a "c_node" but it isn't foreign. *)
+        type t = foreign_node
+
+        let is_null = foreign_node_is_null
+
+        (* CR-soon mshinwell: maybe rename ...c_node_call_site -> c_node_pc,
+           since it isn't a call site in this case. *)
+        external callee : t -> Function_entry_point.t
+          = "caml_spacetime_only_works_for_native_code"
+            "caml_spacetime_c_node_call_site"
+
+        (* This can return a node satisfying "is_null" in the case of an
+           uninitialised tail call point.  See the comment in the C code. *)
+        external callee_node : t -> node
+          = "caml_spacetime_only_works_for_native_code"
+            "caml_spacetime_c_node_callee_node" "noalloc"
+
+        external next : t -> foreign_node
+          = "caml_spacetime_only_works_for_native_code"
+            "caml_spacetime_c_node_next" "noalloc"
+
+        let next t =
+          let next = next t in
+          if foreign_node_is_null next then None
+          else Some next
+      end
+
+      external callees : ocaml_node -> int -> Callee.t
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_ocaml_indirect_call_point_callees"
+          "noalloc"
+
+      let callees t =
+        let callees = callees t.node t.offset in
+        if Callee.is_null callees then None
+        else Some callees
+    end
+
+    module Field = struct
+      type t = field_iterator
+
+      type direct_call_point =
+        | To_ocaml of ocaml_node Direct_call_point.t
+        | To_foreign of foreign_node Direct_call_point.t
+        | To_uninstrumented of
+            uninstrumented_node Direct_call_point.t
+
+      type classification =
+        | Allocation of Allocation_point.t
+        | Direct_call of direct_call_point
+        | Indirect_call of Indirect_call_point.t
+
+      external classify_direct_call_point : ocaml_node -> int -> int
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_classify_direct_call_point"
+          "noalloc"
+
+      let classify t =
+        match t.part_of_shape with
+        | Shape_table.Direct_call callee ->
+          let direct_call_point =
+            match classify_direct_call_point t.node t.offset with
+            | 0 ->
+              (* We should never classify uninitialised call points here. *)
+              assert false
+            | 1 -> To_ocaml t
+            | 2 -> To_foreign t
+            | _ -> assert false
+          in
+          Direct_call direct_call_point
+        | Shape_table.Indirect_call _ -> Indirect_call t
+        | Shape_table.Allocation_point _ -> Allocation t
+
+      (* CR-soon mshinwell: change to "is_unused"? *)
+      let is_uninitialised t =
+        let offset_to_node_hole =
+          match t.part_of_shape with
+          | Shape_table.Direct_call _ -> Some 0
+          | Shape_table.Indirect_call _ -> Some 0
+          | Shape_table.Allocation_point _ -> None
+        in
+        match offset_to_node_hole with
+        | None -> false
+        | Some offset_to_node_hole ->
+          (* There are actually two cases:
+             1. A normal unused node hole, which says Val_unit;
+             2. An unused tail call point.  This will contain a pointer to the
+                start of the current node, but it also has the bottom bit
+                set. *)
+          let offset = t.offset + offset_to_node_hole in
+          Obj.is_int (Obj.field (Obj.repr t.node) offset)
+
+      let rec next t =
+        match t.remaining_layout with
+        | [] -> None
+        | part_of_shape::remaining_layout ->
+          let size = Shape_table.part_of_shape_size t.part_of_shape in
+          let offset = t.offset + size in
+          assert (offset < Obj.size (Obj.repr t.node));
+          let t =
+            { node = t.node;
+              offset;
+              part_of_shape;
+              remaining_layout;
+              shape_table = t.shape_table;
+            }
+          in
+          skip_uninitialised t
+
+      and skip_uninitialised t =
+        if not (is_uninitialised t) then Some t
+        else next t
+    end
+
+    module Node = struct
+      type t = ocaml_node
+
+      external function_identifier : t -> Function_identifier.t
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_ocaml_function_identifier"
+
+      external next_in_tail_call_chain : t -> t
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_ocaml_tail_chain" "noalloc"
+
+      external compare : t -> t -> int
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_compare_node" "noalloc"
+
+      let fields t ~shape_table =
+        match Shape_table.find_exn (function_identifier t) shape_table with
+        | exception Not_found -> None
+        | [] -> None
+        | part_of_shape::remaining_layout ->
+          let t =
+            { node = t;
+              offset = Lazy.force num_header_words;
+              part_of_shape;
+              remaining_layout;
+              shape_table;
+            }
+          in
+          Field.skip_uninitialised t
+    end
+  end
+
+  module Foreign = struct
+    module Node = struct
+      type t = foreign_node
+
+      external compare : t -> t -> int
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_compare_node" "noalloc"
+
+      let fields t =
+        if foreign_node_is_null t then None
+        else Some t
+    end
+
+    module Allocation_point = struct
+      type t = foreign_node
+
+      external program_counter : t -> Program_counter.Foreign.t
+        (* This is not a mistake; the same C function works. *)
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_c_node_call_site"
+
+      external annotation : t -> Annotation.t
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_c_node_profinfo" "noalloc"
+
+      external num_words_including_headers : t -> int
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_c_node_allocation_count" "noalloc"
+    end
+
+    module Call_point = struct
+      type t = foreign_node
+
+      external call_site : t -> Program_counter.Foreign.t
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_c_node_call_site"
+
+      (* May return a null node.  See comment above and the C code. *)
+      external callee_node : t -> node
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_c_node_callee_node" "noalloc"
+    end
+
+    module Field = struct
+      type t = foreign_node
+
+      type classification =
+        | Allocation of Allocation_point.t
+        | Call of Call_point.t
+
+      external is_call : t -> bool
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_c_node_is_call" "noalloc"
+
+      let classify t =
+        if is_call t then Call t
+        else Allocation t
+
+      external next : t -> t
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_c_node_next" "noalloc"
+
+      let next t =
+        let next = next t in
+        if foreign_node_is_null next then None
+        else Some next
+    end
+  end
+
+  module Node = struct
+    module T = struct
+      type t = node
+
+      external compare : t -> t -> int
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_compare_node" "noalloc"
+    end
+
+    include T
+
+    type classification =
+      | OCaml of OCaml.Node.t
+      | Foreign of Foreign.Node.t
+
+    (* CR-soon lwhite: These functions should work in bytecode *)
+    external is_ocaml_node : t -> bool
+      = "caml_spacetime_only_works_for_native_code"
+        "caml_spacetime_is_ocaml_node" "noalloc"
+
+    let classify t =
+      if is_ocaml_node t then OCaml ((Obj.magic t) : ocaml_node)
+      else Foreign ((Obj.magic t) : foreign_node)
+
+    let of_ocaml_node (node : ocaml_node) : t = Obj.magic node
+    let of_foreign_node (node : foreign_node) : t = Obj.magic node
+
+    module Map = Map.Make (T)
+    module Set = Set.Make (T)
+  end
+
+  let root t = t
+end
+
+module Heap_snapshot = struct
+
+  module Entries = struct
+    type t = int array  (* == "struct snapshot_entries" *)
+
+    let length t =
+      let length = Array.length t in
+      assert (length mod 3 = 0);
+      length / 3
+
+    let annotation t idx = t.(idx*3)
+    let num_blocks t idx = t.(idx*3 + 1)
+    let num_words_including_headers t idx = t.(idx*3 + 2)
+  end
+
+  type total_allocations =
+    | End
+    | Total of {
+        annotation : Annotation.t;
+        count : int;
+        next : total_allocations;
+      }
+
+  let (_ : total_allocations) =  (* suppress compiler warning *)
+    Total { annotation = 0; count = 0; next = End; }
+
+  type t = {
+    timestamp : float;
+    gc_stats : Gc_stats.t;
+    entries : Entries.t;
+    words_scanned : int;
+    words_scanned_with_profinfo : int;
+    total_allocations : total_allocations;
+  }
+
+  type heap_snapshot = t
+
+  let timestamp t = t.timestamp
+  let gc_stats t = t.gc_stats
+  let entries t = t.entries
+  let words_scanned t = t.words_scanned
+  let words_scanned_with_profinfo t = t.words_scanned_with_profinfo
+
+  module Total_allocation = struct
+    type t = total_allocations  (* [End] is forbidden *)
+
+    let annotation = function
+      | End -> assert false
+      | Total { annotation; _ } -> annotation
+
+    let num_words_including_headers = function
+      | End -> assert false
+      | Total { count; _ } -> count
+
+    let next = function
+      | End -> assert false
+      | Total { next = End; _ } -> None
+      | Total { next; _ } -> Some next
+  end
+
+  let total_allocations t =
+    match t.total_allocations with
+    | End -> None
+    | (Total _) as totals -> Some totals
+
+  module Event = struct
+    type t = {
+      event_name : string;
+      time : float;
+    }
+
+    let event_name t = t.event_name
+    let timestamp t = t.time
+  end
+
+  module Series = struct
+    type t = {
+      num_snapshots : int;
+      time_of_writer_close : float;
+      frame_table : Frame_table.t;
+      shape_table : Shape_table.t;
+      traces_by_thread : Trace.t array;
+      finaliser_traces_by_thread : Trace.t array;
+      snapshots : heap_snapshot array;
+      events : Event.t list;
+    }
+
+    let pathname_suffix_trace = "trace"
+
+    (* The order of these constructors must match the C code. *)
+    type what_comes_next =
+      | Snapshot
+      | Traces
+      | Event
+
+    (* Suppress compiler warning 37. *)
+    let _ : what_comes_next list = [Snapshot; Traces; Event;]
+
+    let rec read_snapshots_and_events chn snapshots events =
+      let next : what_comes_next = Marshal.from_channel chn in
+      match next with
+      | Snapshot ->
+        let snapshot : heap_snapshot = Marshal.from_channel chn in
+        read_snapshots_and_events chn (snapshot :: snapshots) events
+      | Event ->
+        let event_name : string = Marshal.from_channel chn in
+        let time : float = Marshal.from_channel chn in
+        let event = { Event. event_name; time; } in
+        read_snapshots_and_events chn snapshots (event :: events)
+      | Traces ->
+        (Array.of_list (List.rev snapshots)), List.rev events
+
+    let read ~path =
+      let chn = open_in path in
+      let magic_number : int = Marshal.from_channel chn in
+      let magic_number_base = magic_number land 0xffff_ffff in
+      let version_number = magic_number lsr 32 in
+      if magic_number_base <> 0xace00ace then begin
+        failwith "Raw_spacetime_lib: not a Spacetime profiling file"
+      end else begin
+        match version_number with
+        | 0 ->
+          let snapshots, events = read_snapshots_and_events chn [] [] in
+          let num_snapshots = Array.length snapshots in
+          let time_of_writer_close : float = Marshal.from_channel chn in
+          let frame_table = Frame_table.demarshal chn in
+          let shape_table = Shape_table.demarshal chn in
+          let num_threads : int = Marshal.from_channel chn in
+          let traces_by_thread = Array.init num_threads (fun _ -> None) in
+          let finaliser_traces_by_thread =
+            Array.init num_threads (fun _ -> None)
+          in
+          for thread = 0 to num_threads - 1 do
+            let trace : Trace.t = Trace.unmarshal chn in
+            let finaliser_trace : Trace.t = Trace.unmarshal chn in
+            traces_by_thread.(thread) <- trace;
+            finaliser_traces_by_thread.(thread) <- finaliser_trace
+          done;
+          close_in chn;
+          { num_snapshots;
+            time_of_writer_close;
+            frame_table;
+            shape_table;
+            traces_by_thread;
+            finaliser_traces_by_thread;
+            snapshots;
+            events;
+          }
+        | _ ->
+          failwith "Raw_spacetime_lib: unknown Spacetime profiling file \
+            version number"
+      end
+
+    type trace_kind = Normal | Finaliser
+
+    let num_threads t = Array.length t.traces_by_thread
+
+    let trace t ~kind ~thread_index =
+      if thread_index < 0 || thread_index >= num_threads t then None
+      else
+        match kind with
+        | Normal -> Some t.traces_by_thread.(thread_index)
+        | Finaliser -> Some t.finaliser_traces_by_thread.(thread_index)
+
+    let num_snapshots t = t.num_snapshots
+    let snapshot t ~index = t.snapshots.(index)
+    let frame_table t = t.frame_table
+    let shape_table t = t.shape_table
+    let time_of_writer_close t = t.time_of_writer_close
+    let events t = t.events
+  end
+end
diff --git a/otherlibs/raw_spacetime_lib/raw_spacetime_lib.mli b/otherlibs/raw_spacetime_lib/raw_spacetime_lib.mli
new file mode 100644
index 00000000..51bbc91f
--- /dev/null
+++ b/otherlibs/raw_spacetime_lib/raw_spacetime_lib.mli
@@ -0,0 +1,349 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   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.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Access to the information recorded by the [Spacetime]
+    module.  (It is intended that this module will be used by
+    post-processors rather than users wishing to understand their
+    programs.)
+    For 64-bit targets only.
+    This module may be used from any program, not just one compiled
+    with a compiler configured for Spacetime. *)
+
+module Gc_stats : sig
+  type t
+
+  val minor_words : t -> int
+  val promoted_words : t -> int
+  val major_words : t -> int
+  val minor_collections : t -> int
+  val major_collections : t -> int
+  val heap_words : t -> int
+  val heap_chunks : t -> int
+  val compactions : t -> int
+  val top_heap_words : t -> int
+end
+
+module Annotation : sig
+  (** An annotation written into a value's header.  These may be looked up
+      in a [Trace.t] (see below). *)
+  type t
+
+  (* CR-someday mshinwell: consider using tag and size to increase the
+     available space of annotations.  Need to be careful of [Obj.truncate].
+     Could also randomise the tags on records.
+  *)
+
+  val to_int : t -> int
+end
+
+module Program_counter : sig
+  module OCaml : sig
+    type t
+
+    val to_int64 : t -> Int64.t
+  end
+
+  module Foreign : sig
+    type t
+
+    val to_int64 : t -> Int64.t
+  end
+
+end
+
+module Frame_table : sig
+  (* CR-someday mshinwell: move to [Gc] if dependencies permit? *)
+  (** A value of type [t] corresponds to the frame table of a running
+      OCaml program.  The table is indexed by program counter address
+      (typically, but not always when using Spacetime, return addresses). *)
+  type t
+
+  (** Find the location, including any inlined frames, corresponding to the
+      given program counter address.  Raises [Not_found] if the location
+      could not be resolved. *)
+  val find_exn : Program_counter.OCaml.t -> t -> Printexc.Slot.t list
+end
+
+module Function_entry_point : sig
+  type t
+
+  val to_int64 : t -> Int64.t
+end
+
+module Function_identifier : sig
+  type t
+  (* CR-soon mshinwell: same as [Function_entry_point] now *)
+  val to_int64 : t -> Int64.t
+end
+
+module Shape_table : sig
+  type t
+end
+
+module Trace : sig
+  (** A value of type [t] holds the dynamic call structure of the program
+      (i.e. which functions have called which other functions) together with
+      information required to decode profiling annotations written into
+      values' headers. *)
+  type t
+
+  type node
+  type ocaml_node
+  type foreign_node
+  type uninstrumented_node
+
+  module OCaml : sig
+    module Allocation_point : sig
+      (** A value of type [t] corresponds to an allocation point in OCaml
+          code. *)
+      type t
+
+      (** The program counter at (or close to) the allocation site. *)
+      val program_counter : t -> Program_counter.OCaml.t
+
+      (** The annotation written into the headers of boxed values allocated
+          at the given allocation site. *)
+      val annotation : t -> Annotation.t
+
+      (** The total number of words allocated at this point. *)
+      val num_words_including_headers : t -> int
+    end
+
+    module Direct_call_point : sig
+      (** A value of type ['target t] corresponds to a direct (i.e. known
+          at compile time) call point in OCaml code.  ['target] is the type
+          of the node corresponding to the callee. *)
+      type 'target t
+
+      (** The program counter at (or close to) the call site. *)
+      val call_site : _ t -> Program_counter.OCaml.t
+
+      (** The address of the first instruction of the callee. *)
+      val callee : _ t -> Function_entry_point.t
+
+      (** The node corresponding to the callee. *)
+      val callee_node : 'target t -> 'target
+    end
+
+    module Indirect_call_point : sig
+      (** A value of type [t] corresponds to an indirect call point in OCaml
+          code.  Each such value contains a list of callees to which the
+          call point has branched. *)
+      type t
+
+      (** The program counter at (or close to) the call site. *)
+      val call_site : t -> Program_counter.OCaml.t
+
+      module Callee : sig
+        type t
+
+        (** The address of the first instruction of the callee. *)
+        val callee : t -> Function_entry_point.t
+
+        (** The node corresponding to the callee. *)
+        val callee_node : t -> node
+
+        (** Move to the next callee to which this call point has branched.
+            [None] is returned when the end of the list is reached. *)
+        val next : t -> t option
+      end
+
+      (** The list of callees to which this indirect call point has
+          branched. *)
+      val callees : t -> Callee.t option
+    end
+
+    module Field : sig
+      (** A value of type [t] enables iteration through the contents
+          ("fields") of an OCaml node. *)
+      type t
+
+      type direct_call_point =
+        | To_ocaml of ocaml_node Direct_call_point.t
+        | To_foreign of foreign_node Direct_call_point.t
+        (* CR-soon mshinwell: once everything's finished, "uninstrumented"
+           should be able to go away.  Let's try to do this after the
+           first release. *)
+        | To_uninstrumented of
+            uninstrumented_node Direct_call_point.t
+
+      type classification =
+        | Allocation of Allocation_point.t
+        | Direct_call of direct_call_point
+        | Indirect_call of Indirect_call_point.t
+
+      val classify : t -> classification
+      val next : t -> t option
+    end
+
+    module Node : sig
+      (** A node corresponding to an invocation of a function written in
+          OCaml. *)
+      type t = ocaml_node
+
+      val compare : t -> t -> int
+
+      (** A unique identifier for the function corresponding to this node. *)
+      val function_identifier : t -> Function_identifier.t
+
+      (** This function traverses a circular list. *)
+      val next_in_tail_call_chain : t -> t
+
+      val fields : t -> shape_table:Shape_table.t -> Field.t option
+    end
+  end
+
+  module Foreign : sig
+    module Allocation_point : sig
+      (** A value of type [t] corresponds to an allocation point in non-OCaml
+          code. *)
+      type t
+
+      val program_counter : t -> Program_counter.Foreign.t
+      val annotation : t -> Annotation.t
+      val num_words_including_headers : t -> int
+    end
+
+    module Call_point : sig
+      (** A value of type [t] corresponds to a call point from non-OCaml
+          code (to either non-OCaml code, or OCaml code via the usual
+          assembly veneer). *)
+      type t
+
+      (** N.B. The address of the callee (of type [Function_entry_point.t]) is
+          not available.  It must be recovered during post-processing. *)
+      val call_site : t -> Program_counter.Foreign.t
+      val callee_node : t -> node
+    end
+
+    module Field : sig
+      (** A value of type [t] enables iteration through the contents ("fields")
+          of a C node. *)
+      type t
+
+      type classification = private
+        | Allocation of Allocation_point.t
+        | Call of Call_point.t
+
+      val classify : t -> classification
+      val next : t -> t option
+    end
+
+    module Node : sig
+      (** A node corresponding to an invocation of a function written in C
+          (or any other language that is not OCaml). *)
+      type t = foreign_node
+
+      val compare : t -> t -> int
+
+      val fields : t -> Field.t option
+
+    end
+
+  end
+
+  module Node : sig
+    (** Either an OCaml or a foreign node; or an indication that this
+        is a branch of the graph corresponding to uninstrumented
+        code. *)
+    type t = node
+
+    val compare : t -> t -> int
+
+    type classification = private
+      | OCaml of OCaml.Node.t
+      | Foreign of Foreign.Node.t
+
+    val classify : t -> classification
+
+    val of_ocaml_node : OCaml.Node.t -> t
+    val of_foreign_node : Foreign.Node.t -> t
+
+    module Set : Set.S with type elt = t
+    module Map : Map.S with type key = t
+  end
+
+  (** Obtains the root of the graph for traversal.  [None] is returned if
+      the graph is empty. *)
+  val root : t -> Node.t option
+end
+
+module Heap_snapshot : sig
+  type t
+  type heap_snapshot = t
+
+  module Entries : sig
+    (** An immutable array of the total number of blocks (= boxed
+        values) and the total number of words occupied by such blocks
+        (including their headers) for each profiling annotation in
+        the heap. *)
+    type t
+
+    val length : t -> int
+    val annotation : t -> int -> Annotation.t
+    val num_blocks : t -> int -> int
+    val num_words_including_headers : t -> int -> int
+
+  end
+
+  (** The timestamp of a snapshot.  The units are as for [Sys.time]
+      (unless custom timestamps are being provided, cf. the [Spacetime] module
+      in the standard library). *)
+  val timestamp : t -> float
+
+  val gc_stats : t -> Gc_stats.t
+  val entries : t -> Entries.t
+  val words_scanned : t -> int
+  val words_scanned_with_profinfo : t -> int
+
+  module Total_allocation : sig
+    type t
+
+    val annotation : t -> Annotation.t
+    val num_words_including_headers : t -> int
+    val next : t -> t option
+  end
+  (** Total allocations across *all threads*. *)
+  (* CR-someday mshinwell: change the relevant variables to be thread-local *)
+  val total_allocations : t -> Total_allocation.t option
+
+  module Event : sig
+    type t
+
+    val event_name : t -> string
+    val timestamp : t -> float
+  end
+
+  module Series : sig
+    type t
+
+    (** At present, the [Trace.t] associated with a [Series.t] cannot be
+        garbage collected or freed.  This should not be a problem, since
+        the intention is that a post-processor reads the trace and outputs
+        another format. *)
+    val read : path:string -> t
+
+    val time_of_writer_close : t -> float
+    val num_threads : t -> int
+
+    type trace_kind = Normal | Finaliser
+    val trace : t -> kind:trace_kind -> thread_index:int -> Trace.t option
+
+    val frame_table : t -> Frame_table.t
+    val shape_table : t -> Shape_table.t
+    val num_snapshots : t -> int
+    val snapshot : t -> index:int -> heap_snapshot
+    val events : t -> Event.t list
+  end
+end
diff --git a/otherlibs/str/.depend b/otherlibs/str/.depend
index 53483c9c..6625198e 100644
--- a/otherlibs/str/.depend
+++ b/otherlibs/str/.depend
@@ -2,9 +2,7 @@ strstubs.o: strstubs.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/memory.h \
-  ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \
-  ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \
-  ../../byterun/caml/address_class.h ../../byterun/caml/fail.h
-str.cmi :
+  ../../byterun/caml/fail.h
 str.cmo : str.cmi
 str.cmx : str.cmi
+str.cmi :
diff --git a/otherlibs/str/Makefile b/otherlibs/str/Makefile
index 82685f10..7ab2f11f 100644
--- a/otherlibs/str/Makefile
+++ b/otherlibs/str/Makefile
@@ -13,23 +13,4 @@
 #*                                                                        *
 #**************************************************************************
 
-# Makefile for the str library
-
-
-LIBNAME=str
-COBJS=strstubs.$(O)
-CLIBNAME=camlstr
-CAMLOBJS=str.cmo
-
-include ../Makefile
-
-depend:
-
-str.cmo: str.cmi
-str.cmx: str.cmi
-
-depend:
-	$(CC) -MM $(CFLAGS) *.c > .depend
-	$(CAMLRUN) ../../tools/ocamldep *.mli *.ml >> .depend
-
-include .depend
+include Makefile.shared
diff --git a/otherlibs/str/Makefile.nt b/otherlibs/str/Makefile.nt
index 908a3f1e..202a3cb8 100644
--- a/otherlibs/str/Makefile.nt
+++ b/otherlibs/str/Makefile.nt
@@ -13,16 +13,9 @@
 #*                                                                        *
 #**************************************************************************
 
-# Makefile for the str library
+include Makefile.shared
 
-LIBNAME=str
-COBJS=strstubs.$(O)
-CLIBNAME=camlstr
-CAMLOBJS=str.cmo
+.depend.nt: .depend
+	sed -e 's/\.o/.$(O)/g' .depend > .depend.nt
 
-include ../Makefile.nt
-
-depend:
-
-str.cmo: str.cmi
-str.cmx: str.cmi
+include .depend.nt
diff --git a/otherlibs/str/Makefile.shared b/otherlibs/str/Makefile.shared
new file mode 100644
index 00000000..b5010308
--- /dev/null
+++ b/otherlibs/str/Makefile.shared
@@ -0,0 +1,32 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            Xavier Leroy, projet Cristal, INRIA Rocquencourt            *
+#*                                                                        *
+#*   Copyright 1999 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# Makefile for the str library
+
+LIBNAME=str
+COBJS=strstubs.$(O)
+CLIBNAME=camlstr
+CAMLOBJS=str.cmo
+
+include ../Makefile
+
+str.cmo: str.cmi
+str.cmx: str.cmi
+
+depend:
+	$(CC) -MM $(CFLAGS) *.c > .depend
+	$(CAMLRUN) ../../tools/ocamldep -slash *.mli *.ml >> .depend
+
+include .depend
diff --git a/otherlibs/str/str.ml b/otherlibs/str/str.ml
index b74cee0c..63c19715 100644
--- a/otherlibs/str/str.ml
+++ b/otherlibs/str/str.ml
@@ -163,16 +163,16 @@ let displ dest from = dest - from - 1
 (* Determine if a regexp can match the empty string *)
 
 let rec is_nullable = function
-    Char c -> false
+    Char _ -> false
   | String s -> s = ""
-  | CharClass(cl, cmpl) -> false
+  | CharClass _ -> false
   | Seq rl -> List.for_all is_nullable rl
   | Alt (r1, r2) -> is_nullable r1 || is_nullable r2
-  | Star r -> true
+  | Star _ -> true
   | Plus r -> is_nullable r
-  | Option r -> true
-  | Group(n, r) -> is_nullable r
-  | Refgroup n -> true
+  | Option _ -> true
+  | Group(_, r) -> is_nullable r
+  | Refgroup _ -> true
   | Bol -> true
   | Eol -> true
   | Wordboundary -> true
@@ -187,11 +187,11 @@ let rec first = function
   | CharClass(cl, cmpl) -> if cmpl then Charset.complement cl else cl
   | Seq rl -> first_seq rl
   | Alt (r1, r2) -> Charset.union (first r1) (first r2)
-  | Star r -> Charset.full
+  | Star _ -> Charset.full
   | Plus r -> first r
-  | Option r -> Charset.full
-  | Group(n, r) -> first r
-  | Refgroup n -> Charset.full
+  | Option _ -> Charset.full
+  | Group(_, r) -> first r
+  | Refgroup _ -> Charset.full
   | Bol -> Charset.full
   | Eol -> Charset.full
   | Wordboundary -> Charset.full
@@ -201,7 +201,7 @@ and first_seq = function
   | (Bol | Eol | Wordboundary) :: rl -> first_seq rl
   | Star r :: rl -> Charset.union (first r) (first_seq rl)
   | Option r :: rl -> Charset.union (first r) (first_seq rl)
-  | r :: rl -> first r
+  | r :: _ -> first r
 
 (* Transform a Char or CharClass regexp into a character class *)
 
diff --git a/otherlibs/systhreads/.depend b/otherlibs/systhreads/.depend
index 03da2d85..5181e939 100644
--- a/otherlibs/systhreads/.depend
+++ b/otherlibs/systhreads/.depend
@@ -11,18 +11,18 @@ st_stubs.o: st_stubs.c ../../byterun/caml/alloc.h \
   ../../byterun/caml/printexc.h ../../byterun/caml/roots.h \
   ../../byterun/caml/signals.h ../../byterun/caml/stacks.h \
   ../../byterun/caml/sys.h threads.h st_posix.h
-condition.cmi : mutex.cmi
-event.cmi :
-mutex.cmi :
-thread.cmi :
-threadUnix.cmi :
 condition.cmo : mutex.cmi condition.cmi
 condition.cmx : mutex.cmx condition.cmi
+condition.cmi : mutex.cmi
 event.cmo : mutex.cmi condition.cmi event.cmi
 event.cmx : mutex.cmx condition.cmx event.cmi
+event.cmi :
 mutex.cmo : mutex.cmi
 mutex.cmx : mutex.cmi
+mutex.cmi :
 thread.cmo : thread.cmi
 thread.cmx : thread.cmi
+thread.cmi :
 threadUnix.cmo : thread.cmi threadUnix.cmi
 threadUnix.cmx : thread.cmx threadUnix.cmi
+threadUnix.cmi :
diff --git a/otherlibs/systhreads/Makefile b/otherlibs/systhreads/Makefile
index 1091e232..87e071a6 100644
--- a/otherlibs/systhreads/Makefile
+++ b/otherlibs/systhreads/Makefile
@@ -117,6 +117,6 @@ installopt:
 
 depend: $(GENFILES)
 	-$(CC) -MM -I../../byterun *.c > .depend
-	$(CAMLRUN) ../../tools/ocamldep *.mli *.ml >> .depend
+	$(CAMLRUN) ../../tools/ocamldep -slash *.mli *.ml >> .depend
 
 include .depend
diff --git a/otherlibs/systhreads/Makefile.nt b/otherlibs/systhreads/Makefile.nt
index 48e3bdcd..e1dd2c36 100644
--- a/otherlibs/systhreads/Makefile.nt
+++ b/otherlibs/systhreads/Makefile.nt
@@ -35,8 +35,8 @@ else
   export OCAML_FLEXLINK:=../../boot/ocamlrun ../../flexdll/flexlink.exe
 endif
 
-CAMLOBJS=thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo
-CMIFILES=$(CAMLOBJS:.cmo=.cmi)
+THREAD_OBJS=thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo
+CMIFILES=$(THREAD_OBJS:.cmo=.cmi)
 COBJS=st_stubs_b.$(O)
 COBJS_NAT=st_stubs_n.$(O)
 
@@ -46,9 +46,9 @@ all: lib$(LIBNAME).$(A) $(LIBNAME).cma $(CMIFILES)
 
 allopt: lib$(LIBNAME).$(A) $(LIBNAME).cmxa $(LIBNAME).cmxs $(CMIFILES)
 
-$(LIBNAME).cma: $(CAMLOBJS)
+$(LIBNAME).cma: $(THREAD_OBJS)
 	$(MKLIB) -o $(LIBNAME) -ocamlc "$(CAMLRUN) ../../ocamlc" \
-	         -linkall $(CAMLOBJS) $(LINKOPTS)
+	         -linkall $(THREAD_OBJS) $(LINKOPTS)
 
 lib$(LIBNAME).$(A): $(COBJS)
 	$(MKLIB) -o $(LIBNAME) $(COBJS) $(LDOPTS)
@@ -59,10 +59,10 @@ st_stubs_b.$(O): st_stubs.c st_win32.h
 
 
 
-$(LIBNAME).cmxa: $(CAMLOBJS:.cmo=.cmx)
+$(LIBNAME).cmxa: $(THREAD_OBJS:.cmo=.cmx)
 	$(MKLIB) -o $(LIBNAME)nat \
 	         -ocamlopt "$(CAMLRUN) ../../ocamlopt" -linkall \
-	         $(CAMLOBJS:.cmo=.cmx) $(LINKOPTS)
+	         $(THREAD_OBJS:.cmo=.cmx) $(LINKOPTS)
 	mv $(LIBNAME)nat.cmxa $(LIBNAME).cmxa
 	mv $(LIBNAME)nat.$(A) $(LIBNAME).$(A)
 
@@ -77,7 +77,7 @@ st_stubs_n.$(O): st_stubs.c st_win32.h
 	            $(NATIVECCCOMPOPTS) -c st_stubs.c
 	mv st_stubs.$(O) st_stubs_n.$(O)
 
-$(CAMLOBJS:.cmo=.cmx): ../../ocamlopt
+$(THREAD_OBJS:.cmo=.cmx): ../../ocamlopt
 
 partialclean:
 	rm -f *.cm*
diff --git a/otherlibs/systhreads/st_posix.h b/otherlibs/systhreads/st_posix.h
index cfa3f6f3..4e4ee19b 100644
--- a/otherlibs/systhreads/st_posix.h
+++ b/otherlibs/systhreads/st_posix.h
@@ -420,7 +420,7 @@ value caml_wait_signal(value sigs) /* ML */
   retcode = sigwait(&set, &signo);
   leave_blocking_section();
   st_check_error(retcode, "Thread.wait_signal");
-  return Val_int(signo);
+  return Val_int(caml_rev_convert_signal_number(signo));
 #else
   invalid_argument("Thread.wait_signal not implemented");
   return Val_int(0);            /* not reached */
diff --git a/otherlibs/systhreads/st_stubs.c b/otherlibs/systhreads/st_stubs.c
index dd7f3f5d..9c91e00c 100644
--- a/otherlibs/systhreads/st_stubs.c
+++ b/otherlibs/systhreads/st_stubs.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include "caml/alloc.h"
 #include "caml/backtrace.h"
 #include "caml/callback.h"
@@ -26,13 +28,17 @@
 #include "caml/roots.h"
 #include "caml/signals.h"
 #ifdef NATIVE_CODE
-#include "stack.h"
+#include "caml/stack.h"
 #else
 #include "caml/stacks.h"
 #endif
 #include "caml/sys.h"
 #include "threads.h"
 
+#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+#include "../../asmrun/spacetime.h"
+#endif
+
 /* Initial size of bytecode stack when a thread is created (4 Ko) */
 #define Thread_stack_size (Stack_size / 4)
 
@@ -72,6 +78,12 @@ struct caml_thread_struct {
   char * exception_pointer;     /* Saved value of caml_exception_pointer */
   struct caml__roots_block * local_roots; /* Saved value of local_roots */
   struct longjmp_buffer * exit_buf; /* For thread exit */
+#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+  value internal_spacetime_trie_root;
+  value internal_spacetime_finaliser_trie_root;
+  value* spacetime_trie_node_ptr;
+  value* spacetime_finaliser_trie_root;
+#endif
 #else
   value * stack_low;            /* The execution stack for this thread */
   value * stack_high;
@@ -162,6 +174,12 @@ static inline void caml_thread_save_runtime_state(void)
   curr_thread->gc_regs = caml_gc_regs;
   curr_thread->exception_pointer = caml_exception_pointer;
   curr_thread->local_roots = local_roots;
+#ifdef WITH_SPACETIME
+  curr_thread->spacetime_trie_node_ptr
+    = caml_spacetime_trie_node_ptr;
+  curr_thread->spacetime_finaliser_trie_root
+    = caml_spacetime_finaliser_trie_root;
+#endif
 #else
   curr_thread->stack_low = stack_low;
   curr_thread->stack_high = stack_high;
@@ -184,6 +202,12 @@ static inline void caml_thread_restore_runtime_state(void)
   caml_gc_regs = curr_thread->gc_regs;
   caml_exception_pointer = curr_thread->exception_pointer;
   local_roots = curr_thread->local_roots;
+#ifdef WITH_SPACETIME
+  caml_spacetime_trie_node_ptr
+    = curr_thread->spacetime_trie_node_ptr;
+  caml_spacetime_finaliser_trie_root
+    = curr_thread->spacetime_finaliser_trie_root;
+#endif
 #else
   stack_low = curr_thread->stack_low;
   stack_high = curr_thread->stack_high;
@@ -316,6 +340,20 @@ static caml_thread_t caml_thread_new_info(void)
   th->exception_pointer = NULL;
   th->local_roots = NULL;
   th->exit_buf = NULL;
+#ifdef WITH_SPACETIME
+  /* CR-someday mshinwell: The commented-out changes here are for multicore,
+     where we think we should have one trie per domain. */
+  th->internal_spacetime_trie_root = Val_unit;
+  th->spacetime_trie_node_ptr =
+    &caml_spacetime_trie_root; /* &th->internal_spacetime_trie_root; */
+  th->internal_spacetime_finaliser_trie_root = Val_unit;
+  th->spacetime_finaliser_trie_root
+    = caml_spacetime_finaliser_trie_root;
+    /* &th->internal_spacetime_finaliser_trie_root; */
+  caml_spacetime_register_thread(
+    th->spacetime_trie_node_ptr,
+    th->spacetime_finaliser_trie_root);
+#endif
 #else
   /* Allocate the stacks */
   th->stack_low = (value *) caml_stat_alloc(Thread_stack_size);
@@ -366,7 +404,13 @@ static void caml_thread_remove_info(caml_thread_t th)
   stat_free(th->stack_low);
 #endif
   if (th->backtrace_buffer != NULL) free(th->backtrace_buffer);
+#ifndef WITH_SPACETIME
   stat_free(th);
+  /* CR-soon mshinwell: consider what to do about the Spacetime trace.  Could
+     perhaps have a hook to save a snapshot on thread termination.
+     For the moment we can't even free [th], since it contains the trie
+     roots. */
+#endif
 }
 
 /* Reinitialize the thread machinery after a fork() (PR#4577) */
diff --git a/otherlibs/threads/.depend b/otherlibs/threads/.depend
index b425264d..741d4253 100644
--- a/otherlibs/threads/.depend
+++ b/otherlibs/threads/.depend
@@ -10,24 +10,24 @@ scheduler.o: scheduler.c ../../byterun/caml/alloc.h \
   ../../byterun/caml/address_class.h ../../byterun/caml/printexc.h \
   ../../byterun/caml/roots.h ../../byterun/caml/signals.h \
   ../../byterun/caml/stacks.h ../../byterun/caml/sys.h
-condition.cmi : mutex.cmi
-event.cmi :
-mutex.cmi :
-thread.cmi : unix.cmo
-threadUnix.cmi : unix.cmo
 condition.cmo : thread.cmi mutex.cmi condition.cmi
 condition.cmx : thread.cmx mutex.cmx condition.cmi
+condition.cmi : mutex.cmi
 event.cmo : mutex.cmi condition.cmi event.cmi
 event.cmx : mutex.cmx condition.cmx event.cmi
+event.cmi :
 marshal.cmo :
 marshal.cmx :
 mutex.cmo : thread.cmi mutex.cmi
 mutex.cmx : thread.cmx mutex.cmi
+mutex.cmi :
 pervasives.cmo : unix.cmo
 pervasives.cmx : unix.cmx
 thread.cmo : unix.cmo thread.cmi
 thread.cmx : unix.cmx thread.cmi
+thread.cmi : unix.cmo
 threadUnix.cmo : unix.cmo thread.cmi threadUnix.cmi
 threadUnix.cmx : unix.cmx thread.cmx threadUnix.cmi
+threadUnix.cmi : unix.cmo
 unix.cmo :
 unix.cmx :
diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile
index 729c444e..dbe02504 100644
--- a/otherlibs/threads/Makefile
+++ b/otherlibs/threads/Makefile
@@ -131,6 +131,6 @@ installopt:
 
 depend:
 	$(CC) -MM $(CFLAGS) *.c > .depend
-	$(CAMLRUN) ../../tools/ocamldep *.mli *.ml >> .depend
+	$(CAMLRUN) ../../tools/ocamldep -slash *.mli *.ml >> .depend
 
 include .depend
diff --git a/otherlibs/threads/pervasives.ml b/otherlibs/threads/pervasives.ml
index a497350a..fe3767d3 100644
--- a/otherlibs/threads/pervasives.ml
+++ b/otherlibs/threads/pervasives.ml
@@ -189,14 +189,14 @@ external classify_float : (float [@unboxed]) -> fpclass =
 (* String and byte sequence operations -- more in modules String and Bytes *)
 
 external string_length : string -> int = "%string_length"
-external bytes_length : bytes -> int = "%string_length"
-external bytes_create : int -> bytes = "caml_create_string"
+external bytes_length : bytes -> int = "%bytes_length"
+external bytes_create : int -> bytes = "caml_create_bytes"
 external string_blit : string -> int -> bytes -> int -> int -> unit
                      = "caml_blit_string" [@@noalloc]
 external bytes_blit : bytes -> int -> bytes -> int -> int -> unit
-                        = "caml_blit_string" [@@noalloc]
-external bytes_unsafe_to_string : bytes -> string = "%identity"
-external bytes_unsafe_of_string : string -> bytes = "%identity"
+                        = "caml_blit_bytes" [@@noalloc]
+external bytes_unsafe_to_string : bytes -> string = "%bytes_to_string"
+external bytes_unsafe_of_string : string -> bytes = "%bytes_of_string"
 
 let ( ^ ) s1 s2 =
   let l1 = string_length s1 and l2 = string_length s2 in
@@ -479,7 +479,7 @@ let really_input_string ic len =
   really_input ic s 0 len;
   bytes_unsafe_to_string s
 
-external bytes_set : bytes -> int -> char -> unit = "%string_safe_set"
+external bytes_set : bytes -> int -> char -> unit = "%bytes_safe_set"
 
 let input_line ic =
   let buf = ref (bytes_create 128) in
diff --git a/otherlibs/threads/scheduler.c b/otherlibs/threads/scheduler.c
index 4fb9b1c3..f10bd4e7 100644
--- a/otherlibs/threads/scheduler.c
+++ b/otherlibs/threads/scheduler.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* The thread scheduler */
 
 #include 
diff --git a/otherlibs/unix/.depend b/otherlibs/unix/.depend
index 7e794880..0076ca6d 100644
--- a/otherlibs/unix/.depend
+++ b/otherlibs/unix/.depend
@@ -3,27 +3,20 @@ accept.o: accept.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h socketaddr.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h \
+  socketaddr.h
 access.o: access.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/memory.h \
-  ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \
-  ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \
-  ../../byterun/caml/address_class.h ../../byterun/caml/signals.h \
-  unixsupport.h
+  ../../byterun/caml/signals.h unixsupport.h
 addrofstr.o: addrofstr.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/fail.h unixsupport.h socketaddr.h
+  ../../byterun/caml/memory.h ../../byterun/caml/fail.h unixsupport.h \
+  socketaddr.h
 alarm.o: alarm.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -38,34 +31,22 @@ chdir.o: chdir.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 chmod.o: chmod.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 chown.o: chown.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 chroot.o: chroot.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 close.o: close.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -75,10 +56,7 @@ closedir.o: closedir.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 connect.o: connect.c ../../byterun/caml/fail.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
@@ -93,10 +71,7 @@ cstringv.o: cstringv.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  unixsupport.h
+  ../../byterun/caml/memory.h unixsupport.h
 dup.o: dup.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -121,26 +96,17 @@ execv.o: execv.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  unixsupport.h
+  ../../byterun/caml/memory.h unixsupport.h
 execve.o: execve.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  unixsupport.h
+  ../../byterun/caml/memory.h unixsupport.h
 execvp.o: execvp.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  unixsupport.h
+  ../../byterun/caml/memory.h unixsupport.h
 exit.o: exit.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -176,10 +142,8 @@ getaddrinfo.o: getaddrinfo.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h cst2constr.h socketaddr.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h \
+  cst2constr.h socketaddr.h
 getcwd.o: getcwd.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -205,10 +169,7 @@ getgr.o: getgr.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/fail.h ../../byterun/caml/alloc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  unixsupport.h
+  ../../byterun/caml/memory.h unixsupport.h
 getgroups.o: getgroups.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -219,10 +180,8 @@ gethost.o: gethost.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h socketaddr.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h \
+  socketaddr.h
 gethostname.o: gethostname.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -238,10 +197,8 @@ getnameinfo.o: getnameinfo.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h socketaddr.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h \
+  socketaddr.h
 getpeername.o: getpeername.c ../../byterun/caml/fail.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
@@ -262,28 +219,19 @@ getproto.o: getproto.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  unixsupport.h
+  ../../byterun/caml/memory.h unixsupport.h
 getpw.o: getpw.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/memory.h \
-  ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \
-  ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \
-  ../../byterun/caml/address_class.h ../../byterun/caml/fail.h \
-  unixsupport.h
+  ../../byterun/caml/fail.h unixsupport.h
 getserv.o: getserv.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  unixsupport.h
+  ../../byterun/caml/memory.h unixsupport.h
 getsockname.o: getsockname.c ../../byterun/caml/fail.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
@@ -304,10 +252,7 @@ gmtime.o: gmtime.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  unixsupport.h
+  ../../byterun/caml/memory.h unixsupport.h
 initgroups.o: initgroups.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -323,10 +268,7 @@ itimer.o: itimer.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  unixsupport.h
+  ../../byterun/caml/memory.h unixsupport.h
 kill.o: kill.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -336,10 +278,7 @@ link.o: link.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 listen.o: listen.c ../../byterun/caml/fail.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
@@ -360,18 +299,12 @@ mkdir.o: mkdir.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 mkfifo.o: mkfifo.c ../../byterun/caml/fail.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 nice.o: nice.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -382,18 +315,13 @@ open.o: open.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/memory.h \
-  ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \
-  ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \
-  ../../byterun/caml/address_class.h ../../byterun/caml/signals.h \
-  unixsupport.h
+  ../../byterun/caml/signals.h unixsupport.h
 opendir.o: opendir.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/alloc.h ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/alloc.h \
+  ../../byterun/caml/signals.h unixsupport.h
 pipe.o: pipe.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -403,18 +331,12 @@ putenv.o: putenv.c ../../byterun/caml/fail.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  unixsupport.h
+  ../../byterun/caml/memory.h unixsupport.h
 read.o: read.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 readdir.o: readdir.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -425,19 +347,13 @@ readlink.o: readlink.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/alloc.h \
+  ../../byterun/caml/fail.h ../../byterun/caml/signals.h unixsupport.h
 rename.o: rename.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 rewinddir.o: rewinddir.c ../../byterun/caml/fail.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
@@ -447,28 +363,20 @@ rmdir.o: rmdir.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 select.o: select.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 sendrecv.o: sendrecv.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h socketaddr.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h \
+  socketaddr.h
 setgid.o: setgid.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -479,10 +387,7 @@ setgroups.o: setgroups.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  unixsupport.h
+  ../../byterun/caml/memory.h unixsupport.h
 setsid.o: setsid.c ../../byterun/caml/fail.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
@@ -521,10 +426,8 @@ socketaddr.o: socketaddr.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/alloc.h ../../byterun/caml/memory.h \
-  ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \
-  ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \
-  ../../byterun/caml/address_class.h unixsupport.h socketaddr.h
+  ../../byterun/caml/alloc.h ../../byterun/caml/memory.h unixsupport.h \
+  socketaddr.h
 socketpair.o: socketpair.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -534,11 +437,8 @@ sockopt.o: sockopt.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/alloc.h ../../byterun/caml/fail.h unixsupport.h \
-  socketaddr.h
+  ../../byterun/caml/memory.h ../../byterun/caml/alloc.h \
+  ../../byterun/caml/fail.h unixsupport.h socketaddr.h
 stat.o: stat.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -558,10 +458,7 @@ symlink.o: symlink.c ../../byterun/caml/fail.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 termios.o: termios.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -576,10 +473,7 @@ times.o: times.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/alloc.h ../../byterun/caml/memory.h \
-  ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \
-  ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \
-  ../../byterun/caml/address_class.h unixsupport.h
+  ../../byterun/caml/alloc.h ../../byterun/caml/memory.h unixsupport.h
 truncate.o: truncate.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -599,26 +493,18 @@ unixsupport.o: unixsupport.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/callback.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/fail.h unixsupport.h cst2constr.h
+  ../../byterun/caml/memory.h ../../byterun/caml/fail.h unixsupport.h \
+  cst2constr.h
 unlink.o: unlink.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 utimes.o: utimes.c ../../byterun/caml/fail.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 wait.o: wait.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -632,13 +518,10 @@ write.o: write.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
-unix.cmi :
-unixLabels.cmi : unix.cmi
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 unix.cmo : unix.cmi
 unix.cmx : unix.cmi
+unix.cmi :
 unixLabels.cmo : unix.cmi unixLabels.cmi
 unixLabels.cmx : unix.cmx unixLabels.cmi
+unixLabels.cmi : unix.cmi
diff --git a/otherlibs/unix/Makefile b/otherlibs/unix/Makefile
index e93696ea..ce3fb748 100644
--- a/otherlibs/unix/Makefile
+++ b/otherlibs/unix/Makefile
@@ -44,6 +44,6 @@ include ../Makefile
 
 depend:
 	$(CC) -MM $(CFLAGS) *.c > .depend
-	$(CAMLRUN) ../../tools/ocamldep *.mli *.ml >> .depend
+	$(CAMLRUN) ../../tools/ocamldep -slash *.mli *.ml >> .depend
 
 include .depend
diff --git a/otherlibs/unix/fork.c b/otherlibs/unix/fork.c
index bd174de5..c8fef37c 100644
--- a/otherlibs/unix/fork.c
+++ b/otherlibs/unix/fork.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include 
 #include 
 #include "unixsupport.h"
diff --git a/otherlibs/unix/ftruncate.c b/otherlibs/unix/ftruncate.c
index 8542786a..7c49f2d6 100644
--- a/otherlibs/unix/ftruncate.c
+++ b/otherlibs/unix/ftruncate.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/kill.c b/otherlibs/unix/kill.c
index 3593369b..7177c18f 100644
--- a/otherlibs/unix/kill.c
+++ b/otherlibs/unix/kill.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include 
 #include 
 #include "unixsupport.h"
diff --git a/otherlibs/unix/lseek.c b/otherlibs/unix/lseek.c
index d8978555..4b3cad41 100644
--- a/otherlibs/unix/lseek.c
+++ b/otherlibs/unix/lseek.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/signals.c b/otherlibs/unix/signals.c
index d1fb3a08..a46e345f 100644
--- a/otherlibs/unix/signals.c
+++ b/otherlibs/unix/signals.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include 
 #include 
 
diff --git a/otherlibs/unix/sleep.c b/otherlibs/unix/sleep.c
index 1357d44c..5f1b6601 100644
--- a/otherlibs/unix/sleep.c
+++ b/otherlibs/unix/sleep.c
@@ -30,8 +30,8 @@
 CAMLprim value unix_sleep(value duration)
 {
   double d = Double_val(duration);
-  if (d <= 0.0) return Val_unit;
-#if _POSIX_C_SOURCE >= 199309L
+  if (d < 0.0) return Val_unit;
+#if defined(HAS_NANOSLEEP)
   {
     struct timespec t;
     int ret;
diff --git a/otherlibs/unix/stat.c b/otherlibs/unix/stat.c
index e2a8f6a9..6cde064e 100644
--- a/otherlibs/unix/stat.c
+++ b/otherlibs/unix/stat.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/truncate.c b/otherlibs/unix/truncate.c
index 4daba78a..d2c6f125 100644
--- a/otherlibs/unix/truncate.c
+++ b/otherlibs/unix/truncate.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/unix.ml b/otherlibs/unix/unix.ml
index e345e9bb..420ee027 100644
--- a/otherlibs/unix/unix.ml
+++ b/otherlibs/unix/unix.ml
@@ -1077,7 +1077,7 @@ let establish_server server_fun sockaddr =
   bind sock sockaddr;
   listen sock 5;
   while true do
-    let (s, caller) = accept_non_intr sock in
+    let (s, _caller) = accept_non_intr sock in
     (* The "double fork" trick, the process which calls server_fun will not
        leave a zombie process *)
     match fork() with
diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli
index cfec2cb6..abb570e6 100644
--- a/otherlibs/unix/unix.mli
+++ b/otherlibs/unix/unix.mli
@@ -716,9 +716,7 @@ val has_symlink : unit -> bool
    simply indicates that the symlink system call is available. *)
 
 val readlink : string -> string
-(** Read the contents of a link.
-
-   On Windows: not implemented. *)
+(** Read the contents of a symbolic link. *)
 
 
 (** {6 Polling} *)
@@ -882,7 +880,9 @@ val sleep : int -> unit
 
 val sleepf : float -> unit
 (** Stop execution for the given number of seconds.  Like [sleep],
-    but fractions of seconds are supported. *)
+    but fractions of seconds are supported.
+
+    @since 4.03.0 *)
 
 val times : unit -> process_times
 (** Return the execution times of the process.
@@ -1066,9 +1066,8 @@ type socket_domain =
   | PF_INET                     (** Internet domain (IPv4) *)
   | PF_INET6                    (** Internet domain (IPv6) *)
 (** The type of socket domains.  Not all platforms support
-    IPv6 sockets (type [PF_INET6]).
-    On Windows, the domains [PF_UNIX] and [PF_INET6] are not
-    supported; [PF_INET] is fully supported. *)
+    IPv6 sockets (type [PF_INET6]).  Windows does not support
+    [PF_UNIX]. *)
 
 type socket_type =
     SOCK_STREAM                 (** Stream socket *)
@@ -1076,7 +1075,9 @@ type socket_type =
   | SOCK_RAW                    (** Raw socket *)
   | SOCK_SEQPACKET              (** Sequenced packets socket *)
 (** The type of socket kinds, specifying the semantics of
-   communications. *)
+   communications.  [SOCK_SEQPACKET] is included for completeness,
+   but is rarely supported by the OS, and needs system calls that
+   are not available in this library. *)
 
 type sockaddr =
     ADDR_UNIX of string
@@ -1366,7 +1367,7 @@ val getaddrinfo:
 
 type name_info =
   { ni_hostname : string;               (** Name or IP address of host *)
-    ni_service : string                 (** Name of service or port number *)
+    ni_service : string;                (** Name of service or port number *)
   }
 (** Host and service information returned by {!Unix.getnameinfo}. *)
 
diff --git a/otherlibs/unix/unixLabels.mli b/otherlibs/unix/unixLabels.mli
index fdf29a1c..b3f67164 100644
--- a/otherlibs/unix/unixLabels.mli
+++ b/otherlibs/unix/unixLabels.mli
@@ -1243,7 +1243,7 @@ val getaddrinfo:
 
 type name_info =
   { ni_hostname : string;               (** Name or IP address of host *)
-    ni_service : string                 (** Name of service or port number *)
+    ni_service : string;                (** Name of service or port number *)
   }
 (** Host and service information returned by {!Unix.getnameinfo}. *)
 
diff --git a/otherlibs/unix/wait.c b/otherlibs/unix/wait.c
index 1d261295..fee298f2 100644
--- a/otherlibs/unix/wait.c
+++ b/otherlibs/unix/wait.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include 
 #include 
 #include 
diff --git a/otherlibs/win32graph/Makefile.nt b/otherlibs/win32graph/Makefile.nt
index 26d9c5a6..e9917ae9 100644
--- a/otherlibs/win32graph/Makefile.nt
+++ b/otherlibs/win32graph/Makefile.nt
@@ -20,7 +20,7 @@ WIN32LIBS=$(call SYSLIB,kernel32) $(call SYSLIB,gdi32) $(call SYSLIB,user32)
 LINKOPTS=-cclib "\"$(WIN32LIBS)\""
 LDOPTS=-ldopt "$(WIN32LIBS)"
 
-include ../Makefile.nt
+include ../Makefile
 
 graphics.ml: ../graph/graphics.ml
 	cp ../graph/graphics.ml graphics.ml
diff --git a/otherlibs/win32graph/events.c b/otherlibs/win32graph/events.c
index 65642838..aaedcfa7 100755
--- a/otherlibs/win32graph/events.c
+++ b/otherlibs/win32graph/events.c
@@ -22,7 +22,8 @@ enum {
   EVENT_BUTTON_DOWN = 1,
   EVENT_BUTTON_UP = 2,
   EVENT_KEY_PRESSED = 4,
-  EVENT_MOUSE_MOTION = 8
+  EVENT_MOUSE_MOTION = 8,
+  EVENT_WINDOW_CLOSED = 16
 };
 
 struct event_data {
@@ -105,6 +106,10 @@ void caml_gr_handle_event(UINT msg, WPARAM wParam, LPARAM lParam)
     last_pos = lParam;
     caml_gr_enqueue_event(EVENT_MOUSE_MOTION, lParam, last_button, 0);
     break;
+  case WM_DESTROY:
+    // Release any calls to Graphics.wait_next_event
+    ReleaseSemaphore(caml_gr_queue_semaphore, 1, NULL);
+    break;
   }
 }
 
@@ -157,15 +162,20 @@ static value caml_gr_wait_event_blocking(int mask)
     /* Pop oldest event in queue */
     EnterCriticalSection(&caml_gr_queue_mutex);
     ev = caml_gr_queue[caml_gr_head];
-    /* Queue should never be empty at this point, but just in case... */
+    /* Empty queue means the window was closed */
     if (QueueIsEmpty) {
-      ev.kind = 0;
+      ev.kind = EVENT_WINDOW_CLOSED;
     } else {
       caml_gr_head = (caml_gr_head + 1) % SIZE_QUEUE;
     }
     LeaveCriticalSection(&caml_gr_queue_mutex);
     /* Check if it matches */
   } while ((ev.kind & mask) == 0);
+
+  if (ev.kind == EVENT_WINDOW_CLOSED) {
+    gr_fail("graphic screen not opened", NULL);
+  }
+
   return caml_gr_wait_allocate_result(ev.mouse_x, ev.mouse_y, ev.button,
                                       ev.kind == EVENT_KEY_PRESSED,
                                       ev.key);
@@ -176,7 +186,7 @@ CAMLprim value caml_gr_wait_event(value eventlist) /* ML */
   int mask, poll;
 
   gr_check_open();
-  mask = 0;
+  mask = EVENT_WINDOW_CLOSED;
   poll = 0;
   while (eventlist != Val_int(0)) {
     switch (Int_val(Field(eventlist, 0))) {
diff --git a/otherlibs/win32graph/open.c b/otherlibs/win32graph/open.c
index 016e52eb..15c029a8 100644
--- a/otherlibs/win32graph/open.c
+++ b/otherlibs/win32graph/open.c
@@ -104,7 +104,6 @@ static LRESULT CALLBACK GraphicsWndProc(HWND hwnd,UINT msg,WPARAM wParam,
                 // End application
         case WM_DESTROY:
                 ResetForClose(hwnd);
-                gr_check_open();
                 break;
         }
         caml_gr_handle_event(msg, wParam, lParam);
diff --git a/otherlibs/win32unix/Makefile b/otherlibs/win32unix/Makefile
deleted file mode 100644
index 58208a3b..00000000
--- a/otherlibs/win32unix/Makefile
+++ /dev/null
@@ -1,18 +0,0 @@
-#**************************************************************************
-#*                                                                        *
-#*                                 OCaml                                  *
-#*                                                                        *
-#*            Xavier Leroy, projet Cristal, INRIA Rocquencourt            *
-#*                                                                        *
-#*   Copyright 1999 Institut National de Recherche en Informatique et     *
-#*     en Automatique.                                                    *
-#*                                                                        *
-#*   All rights reserved.  This file is distributed under the terms of    *
-#*   the GNU Lesser General Public License version 2.1, with the          *
-#*   special exception on linking described in the file LICENSE.          *
-#*                                                                        *
-#**************************************************************************
-
-include Makefile.common
-
-include ../Makefile
diff --git a/otherlibs/win32unix/Makefile.common b/otherlibs/win32unix/Makefile.common
deleted file mode 100644
index 9487db0d..00000000
--- a/otherlibs/win32unix/Makefile.common
+++ /dev/null
@@ -1,63 +0,0 @@
-#**************************************************************************
-#*                                                                        *
-#*                                 OCaml                                  *
-#*                                                                        *
-#*            Xavier Leroy, projet Cristal, INRIA Rocquencourt            *
-#*                                                                        *
-#*   Copyright 1999 Institut National de Recherche en Informatique et     *
-#*     en Automatique.                                                    *
-#*                                                                        *
-#*   All rights reserved.  This file is distributed under the terms of    *
-#*   the GNU Lesser General Public License version 2.1, with the          *
-#*   special exception on linking described in the file LICENSE.          *
-#*                                                                        *
-#**************************************************************************
-
-# Files in this directory
-WIN_FILES = accept.c bind.c channels.c close.c \
-  close_on.c connect.c createprocess.c dup.c dup2.c errmsg.c \
-  getpeername.c getpid.c getsockname.c gettimeofday.c \
-  link.c listen.c lockf.c lseek.c nonblock.c \
-  mkdir.c open.c pipe.c read.c readlink.c rename.c \
-  select.c sendrecv.c \
-  shutdown.c sleep.c socket.c sockopt.c startup.c stat.c \
-  symlink.c system.c times.c unixsupport.c windir.c winwait.c write.c \
-  winlist.c winworker.c windbug.c
-
-# Files from the ../unix directory
-UNIX_FILES = access.c addrofstr.c chdir.c chmod.c cst2constr.c \
-  cstringv.c envir.c execv.c execve.c execvp.c \
-  exit.c getaddrinfo.c getcwd.c gethost.c gethostname.c \
-  getnameinfo.c getproto.c \
-  getserv.c gmtime.c putenv.c rmdir.c \
-  socketaddr.c strofaddr.c time.c unlink.c utimes.c
-
-UNIX_CAML_FILES = unix.mli unixLabels.mli unixLabels.ml
-
-ALL_FILES=$(WIN_FILES) $(UNIX_FILES)
-WSOCKLIB=$(call SYSLIB,ws2_32)
-ADVAPI32LIB=$(call SYSLIB,advapi32)
-
-LIBNAME=unix
-COBJS=$(ALL_FILES:.c=.$(O))
-CAMLOBJS=unix.cmo unixLabels.cmo
-LINKOPTS=-cclib $(WSOCKLIB) -cclib $(ADVAPI32LIB)
-LDOPTS=-ldopt $(WSOCKLIB) -ldopt $(ADVAPI32LIB)
-EXTRACAMLFLAGS=-nolabels
-EXTRACFLAGS=-I../unix
-HEADERS=unixsupport.h socketaddr.h
-
-
-include ../Makefile.nt
-
-clean::
-	rm -f $(UNIX_FILES) $(UNIX_CAML_FILES)
-
-$(UNIX_FILES) $(UNIX_CAML_FILES): %: ../unix/%
-	cp ../unix/$* $*
-
-depend:
-
-$(COBJS): unixsupport.h
-
-include .depend
diff --git a/otherlibs/win32unix/Makefile.nt b/otherlibs/win32unix/Makefile.nt
index bb59270d..ddedd03e 100644
--- a/otherlibs/win32unix/Makefile.nt
+++ b/otherlibs/win32unix/Makefile.nt
@@ -13,6 +13,51 @@
 #*                                                                        *
 #**************************************************************************
 
-include Makefile.common
+# Files in this directory
+WIN_FILES = accept.c bind.c channels.c close.c \
+  close_on.c connect.c createprocess.c dup.c dup2.c errmsg.c \
+  getpeername.c getpid.c getsockname.c gettimeofday.c \
+  link.c listen.c lockf.c lseek.c nonblock.c \
+  mkdir.c open.c pipe.c read.c readlink.c rename.c \
+  select.c sendrecv.c \
+  shutdown.c sleep.c socket.c sockopt.c startup.c stat.c \
+  symlink.c system.c times.c unixsupport.c windir.c winwait.c write.c \
+  winlist.c winworker.c windbug.c
 
-include ../Makefile.nt
+# Files from the ../unix directory
+UNIX_FILES = access.c addrofstr.c chdir.c chmod.c cst2constr.c \
+  cstringv.c envir.c execv.c execve.c execvp.c \
+  exit.c getaddrinfo.c getcwd.c gethost.c gethostname.c \
+  getnameinfo.c getproto.c \
+  getserv.c gmtime.c putenv.c rmdir.c \
+  socketaddr.c strofaddr.c time.c unlink.c utimes.c
+
+UNIX_CAML_FILES = unix.mli unixLabels.mli unixLabels.ml
+
+ALL_FILES=$(WIN_FILES) $(UNIX_FILES)
+WSOCKLIB=$(call SYSLIB,ws2_32)
+ADVAPI32LIB=$(call SYSLIB,advapi32)
+
+LIBNAME=unix
+COBJS=$(ALL_FILES:.c=.$(O))
+CAMLOBJS=unix.cmo unixLabels.cmo
+LINKOPTS=-cclib $(WSOCKLIB) -cclib $(ADVAPI32LIB)
+LDOPTS=-ldopt $(WSOCKLIB) -ldopt $(ADVAPI32LIB)
+EXTRACAMLFLAGS=-nolabels
+EXTRACFLAGS=-I../unix
+HEADERS=unixsupport.h socketaddr.h
+
+
+include ../Makefile
+
+clean::
+	rm -f $(UNIX_FILES) $(UNIX_CAML_FILES)
+
+$(UNIX_FILES) $(UNIX_CAML_FILES): %: ../unix/%
+	cp ../unix/$* $*
+
+depend:
+
+$(COBJS): unixsupport.h
+
+include .depend
diff --git a/otherlibs/win32unix/channels.c b/otherlibs/win32unix/channels.c
index edd83813..1210e6e5 100644
--- a/otherlibs/win32unix/channels.c
+++ b/otherlibs/win32unix/channels.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include 
 #include 
 #include 
@@ -20,6 +22,11 @@
 #include "unixsupport.h"
 #include 
 
+#if defined(_MSC_VER) && !defined(_INTPTR_T_DEFINED)
+typedef int intptr_t;
+#define _INTPTR_T_DEFINED
+#endif
+
 extern intptr_t _get_osfhandle(int);
 extern int _open_osfhandle(intptr_t, int);
 
@@ -41,6 +48,9 @@ CAMLprim value win_inchannel_of_filedescr(value handle)
   CAMLlocal1(vchan);
   struct channel * chan;
 
+#if defined(_MSC_VER) && _MSC_VER < 1400
+  fflush(stdin);
+#endif
   chan = caml_open_descriptor_in(win_CRT_fd_of_filedescr(handle));
   if (Descr_kind_val(handle) == KIND_SOCKET)
     chan->flags |= CHANNEL_FLAG_FROM_SOCKET;
diff --git a/otherlibs/win32unix/gettimeofday.c b/otherlibs/win32unix/gettimeofday.c
index 936cb89e..0afd29b6 100644
--- a/otherlibs/win32unix/gettimeofday.c
+++ b/otherlibs/win32unix/gettimeofday.c
@@ -27,6 +27,14 @@ CAMLprim value unix_gettimeofday(value unit)
   FILETIME ft;
   double tm;
   GetSystemTimeAsFileTime(&ft);
+#if defined(_MSC_VER) && _MSC_VER < 1300
+  /* This compiler can't cast uint64_t to double! Fortunately, this doesn't
+     matter since SYSTEMTIME is only ever 63-bit (maximum value 31-Dec-30827
+     23:59:59.999, and it requires some skill to set the clock past 2099!)
+   */
+  tm = *(int64_t *)&ft - epoch_ft; /* shift to Epoch-relative time */
+#else
   tm = *(uint64_t *)&ft - epoch_ft; /* shift to Epoch-relative time */
+#endif
   return copy_double(tm * 1e-7);  /* tm is in 100ns */
 }
diff --git a/otherlibs/win32unix/readlink.c b/otherlibs/win32unix/readlink.c
index 696d435f..7b20614c 100644
--- a/otherlibs/win32unix/readlink.c
+++ b/otherlibs/win32unix/readlink.c
@@ -26,18 +26,22 @@ CAMLprim value unix_readlink(value opath)
   CAMLparam1(opath);
   CAMLlocal1(result);
   HANDLE h;
-  char* path = String_val(opath);
+  char* path;
   DWORD attributes;
+  caml_unix_check_path(opath, "readlink");
+  path = caml_strdup(String_val(opath));
 
   caml_enter_blocking_section();
   attributes = GetFileAttributes(path);
   caml_leave_blocking_section();
 
   if (attributes == INVALID_FILE_ATTRIBUTES) {
+    caml_stat_free(path);
     win32_maperr(GetLastError());
     uerror("readlink", opath);
   }
   else if (!(attributes & FILE_ATTRIBUTE_REPARSE_POINT)) {
+    caml_stat_free(path);
     errno = EINVAL;
     uerror("readlink", opath);
   }
@@ -51,6 +55,7 @@ CAMLprim value unix_readlink(value opath)
                         FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT,
                         NULL)) == INVALID_HANDLE_VALUE) {
       caml_leave_blocking_section();
+      caml_stat_free(path);
       errno = ENOENT;
       uerror("readlink", opath);
     }
@@ -59,6 +64,8 @@ CAMLprim value unix_readlink(value opath)
       DWORD read;
       REPARSE_DATA_BUFFER* point;
 
+      caml_stat_free(path);
+
       if (DeviceIoControl(h, FSCTL_GET_REPARSE_POINT, NULL, 0, buffer, 16384, &read, NULL)) {
         caml_leave_blocking_section();
         point = (REPARSE_DATA_BUFFER*)buffer;
diff --git a/otherlibs/win32unix/select.c b/otherlibs/win32unix/select.c
index ad77bf96..f693941d 100644
--- a/otherlibs/win32unix/select.c
+++ b/otherlibs/win32unix/select.c
@@ -932,14 +932,19 @@ static value find_handle(LPSELECTRESULT iterResult, value readfds,
 #define MAX(a, b) ((a) > (b) ? (a) : (b))
 
 /* Convert fdlist to an fd_set if all the handles in fdlist are
- * sockets and return 0.  Returns 1 if a non-socket value is
- * encountered.
+ * sockets and return 1.  Returns 0 if a non-socket value is
+ * encountered, or if there are more than FD_SETSIZE sockets.
  */
 static int fdlist_to_fdset(value fdlist, fd_set *fdset)
 {
   value l, c;
+  int n = 0;
   FD_ZERO(fdset);
   for (l = fdlist; l != Val_int(0); l = Field(l, 1)) {
+    if (++n > FD_SETSIZE) {
+      DEBUG_PRINT("More than FD_SETSIZE sockets");
+      return 0;
+    }
     c = Field(l, 0);
     if (Descr_kind_val(c) == KIND_SOCKET) {
       FD_SET(Socket_val(c), fdset);
diff --git a/otherlibs/win32unix/sleep.c b/otherlibs/win32unix/sleep.c
index 1b7af930..6389adea 100644
--- a/otherlibs/win32unix/sleep.c
+++ b/otherlibs/win32unix/sleep.c
@@ -20,8 +20,9 @@
 CAMLprim value unix_sleep(t)
      value t;
 {
+  double d = Double_val(t);
   enter_blocking_section();
-  Sleep(Double_val(t) * 1e3);
+  Sleep(d * 1e3);
   leave_blocking_section();
   return Val_unit;
 }
diff --git a/otherlibs/win32unix/stat.c b/otherlibs/win32unix/stat.c
index 12f5af53..dd5fae22 100644
--- a/otherlibs/win32unix/stat.c
+++ b/otherlibs/win32unix/stat.c
@@ -35,10 +35,14 @@
 #define S_IFLNK (S_IFDIR | S_IFREG)
 #endif
 #ifndef S_IFIFO
-#define S_IFIFO 0
+#ifdef _S_IFIFO
+#define S_IFIFO _S_IFIFO
+#else
+#define S_IFIFO (S_IFREG | S_IFCHR)
+#endif
 #endif
 #ifndef S_IFSOCK
-#define S_IFSOCK 0
+#define S_IFSOCK (S_IFDIR | S_IFCHR)
 #endif
 #ifndef S_IFBLK
 #define S_IFBLK 0
@@ -138,7 +142,8 @@ static int convert_time(FILETIME* time, __time64_t* result, __time64_t def)
   return 1;
 }
 
-static int do_stat(int do_lstat, int use_64, char* path, mlsize_t l, HANDLE fstat, __int64* st_ino, struct _stat64* res)
+/* path allocated outside the OCaml heap */
+static int safe_do_stat(int do_lstat, int use_64, char* path, mlsize_t l, HANDLE fstat, __int64* st_ino, struct _stat64* res)
 {
   BY_HANDLE_FILE_INFORMATION info;
   int i;
@@ -295,6 +300,16 @@ static int do_stat(int do_lstat, int use_64, char* path, mlsize_t l, HANDLE fsta
   return 1;
 }
 
+static int do_stat(int do_lstat, int use_64, char* opath, mlsize_t l, HANDLE fstat, __int64* st_ino, struct _stat64* res)
+{
+  char* path;
+  int ret;
+  path = caml_strdup(opath);
+  ret = safe_do_stat(do_lstat, use_64, path, l, fstat, st_ino, res);
+  caml_stat_free(path);
+  return ret;
+}
+
 CAMLprim value unix_stat(value path)
 {
   struct _stat64 buf;
@@ -323,6 +338,8 @@ CAMLprim value unix_lstat(value path)
 {
   struct _stat64 buf;
   __int64 st_ino;
+
+  caml_unix_check_path(path, "lstat");
   if (!do_stat(1, 0, String_val(path), caml_string_length(path), NULL, &st_ino, &buf)) {
     uerror("lstat", path);
   }
@@ -333,30 +350,66 @@ CAMLprim value unix_lstat_64(value path)
 {
   struct _stat64 buf;
   __int64 st_ino;
+
+  caml_unix_check_path(path, "lstat");
   if (!do_stat(1, 1, String_val(path), caml_string_length(path), NULL, &st_ino, &buf)) {
     uerror("lstat", path);
   }
   return stat_aux(1, st_ino, &buf);
 }
 
-CAMLprim value unix_fstat(value handle)
+static value do_fstat(value handle, int use_64)
 {
   int ret;
   struct _stat64 buf;
   __int64 st_ino;
-  if (!do_stat(0, 0, NULL, 0, Handle_val(handle), &st_ino, &buf)) {
+  HANDLE h;
+  DWORD ft;
+
+  st_ino = 0;
+  memset(&buf, 0, sizeof buf);
+  buf.st_nlink = 1;
+
+  h = Handle_val(handle);
+  ft = GetFileType(h) & ~FILE_TYPE_REMOTE;
+  switch(ft) {
+  case FILE_TYPE_DISK:
+    if (!safe_do_stat(0, use_64, NULL, 0, Handle_val(handle), &st_ino, &buf)) {
+      uerror("fstat", Nothing);
+    }
+    break;
+  case FILE_TYPE_CHAR:
+    buf.st_mode = S_IFCHR;
+    break;
+  case FILE_TYPE_PIPE:
+    {
+      DWORD n_avail;
+      if (Descr_kind_val(handle) == KIND_SOCKET) {
+        buf.st_mode = S_IFSOCK;
+      }
+      else {
+        buf.st_mode = S_IFIFO;
+      }
+      if (PeekNamedPipe(h, NULL, 0, NULL, &n_avail, NULL)) {
+        buf.st_size = n_avail;
+      }
+    }
+    break;
+  case FILE_TYPE_UNKNOWN:
+    unix_error(EBADF, "fstat", Nothing);
+  default:
+    win32_maperr(GetLastError());
     uerror("fstat", Nothing);
   }
-  return stat_aux(0, st_ino, &buf);
+  return stat_aux(use_64, st_ino, &buf);
+}
+
+CAMLprim value unix_fstat(value handle)
+{
+  return do_fstat(handle, 0);
 }
 
 CAMLprim value unix_fstat_64(value handle)
 {
-  int ret;
-  struct _stat64 buf;
-  __int64 st_ino;
-  if (!do_stat(0, 1, NULL, 0, Handle_val(handle), &st_ino, &buf)) {
-    uerror("fstat", Nothing);
-  }
-  return stat_aux(1, st_ino, &buf);
+  return do_fstat(handle, 1);
 }
diff --git a/otherlibs/win32unix/symlink.c b/otherlibs/win32unix/symlink.c
index ec1c4a03..36597ab0 100644
--- a/otherlibs/win32unix/symlink.c
+++ b/otherlibs/win32unix/symlink.c
@@ -29,11 +29,15 @@ typedef BOOLEAN (WINAPI *LPFN_CREATESYMBOLICLINK) (LPTSTR, LPTSTR, DWORD);
 static LPFN_CREATESYMBOLICLINK pCreateSymbolicLink = NULL;
 static int no_symlink = 0;
 
-CAMLprim value unix_symlink(value to_dir, value source, value dest)
+CAMLprim value unix_symlink(value to_dir, value osource, value odest)
 {
-  CAMLparam3(to_dir, source, dest);
+  CAMLparam3(to_dir, osource, odest);
   DWORD flags = (Bool_val(to_dir) ? SYMBOLIC_LINK_FLAG_DIRECTORY : 0);
   BOOLEAN result;
+  LPTSTR source;
+  LPTSTR dest;
+  caml_unix_check_path(osource, "symlink");
+  caml_unix_check_path(odest, "symlink");
 
 again:
   if (no_symlink) {
@@ -46,13 +50,20 @@ again:
     goto again;
   }
 
+  /* Copy source and dest outside the OCaml heap */
+  source = caml_strdup(String_val(osource));
+  dest = caml_strdup(String_val(odest));
+
   caml_enter_blocking_section();
-  result = pCreateSymbolicLink(String_val(dest), String_val(source), flags);
+  result = pCreateSymbolicLink(dest, source, flags);
   caml_leave_blocking_section();
 
+  caml_stat_free(source);
+  caml_stat_free(dest);
+
   if (!result) {
     win32_maperr(GetLastError());
-    uerror("symlink", dest);
+    uerror("symlink", odest);
   }
 
   CAMLreturn(Val_unit);
@@ -76,7 +87,7 @@ CAMLprim value unix_has_symlink(value unit)
 
       if (!GetTokenInformation(hProcess, TokenPrivileges, NULL, 0, &length)) {
         if (GetLastError() == ERROR_INSUFFICIENT_BUFFER) {
-          TOKEN_PRIVILEGES* privileges = (TOKEN_PRIVILEGES*)malloc(length);
+          TOKEN_PRIVILEGES* privileges = (TOKEN_PRIVILEGES*)caml_stat_alloc(length);
           if (GetTokenInformation(hProcess,
                                   TokenPrivileges,
                                   privileges,
@@ -91,7 +102,7 @@ CAMLprim value unix_has_symlink(value unit)
             }
           }
 
-          free(privileges);
+          caml_stat_free(privileges);
         }
       }
     }
diff --git a/otherlibs/win32unix/times.c b/otherlibs/win32unix/times.c
index 00f3bae9..dc0519dc 100644
--- a/otherlibs/win32unix/times.c
+++ b/otherlibs/win32unix/times.c
@@ -20,7 +20,15 @@
 
 
 double to_sec(FILETIME ft) {
+#if defined(_MSC_VER) && _MSC_VER < 1300
+  /* See gettimeofday.c - it is not possible for these values to be 64-bit, so
+     there's no worry about using a signed struct in order to work around the
+     lack of support for casting int64_t to double.
+   */
+  LARGE_INTEGER tmp;
+#else
   ULARGE_INTEGER tmp;
+#endif
 
   tmp.u.LowPart = ft.dwLowDateTime;
   tmp.u.HighPart = ft.dwHighDateTime;
diff --git a/otherlibs/win32unix/unix.ml b/otherlibs/win32unix/unix.ml
index d24bb679..eea61ebb 100644
--- a/otherlibs/win32unix/unix.ml
+++ b/otherlibs/win32unix/unix.ml
@@ -147,7 +147,7 @@ external getpid : unit -> int = "unix_getpid"
 let fork () = invalid_arg "Unix.fork not implemented"
 let wait () = invalid_arg "Unix.wait not implemented"
 let getppid () = invalid_arg "Unix.getppid not implemented"
-let nice prio = invalid_arg "Unix.nice not implemented"
+let nice _ = invalid_arg "Unix.nice not implemented"
 
 (* Basic file input/output *)
 
@@ -224,8 +224,8 @@ type seek_command =
 
 external lseek : file_descr -> int -> seek_command -> int = "unix_lseek"
 
-let truncate name len = invalid_arg "Unix.truncate not implemented"
-let ftruncate fd len = invalid_arg "Unix.ftruncate not implemented"
+let truncate _name _len = invalid_arg "Unix.truncate not implemented"
+let ftruncate _fd _len = invalid_arg "Unix.ftruncate not implemented"
 
 (* File statistics *)
 
@@ -270,9 +270,9 @@ module LargeFile =
   struct
     external lseek : file_descr -> int64 -> seek_command -> int64
        = "unix_lseek_64"
-    let truncate name len =
+    let truncate _name _len =
       invalid_arg "Unix.LargeFile.truncate not implemented"
-    let ftruncate name len =
+    let ftruncate _name _len =
       invalid_arg "Unix.LargeFile.ftruncate not implemented"
     type stats =
       { st_dev : int;
@@ -302,10 +302,10 @@ type access_permission =
   | F_OK
 
 external chmod : string -> file_perm -> unit = "unix_chmod"
-let fchmod fd perm = invalid_arg "Unix.fchmod not implemented"
-let chown file perm = invalid_arg "Unix.chown not implemented"
-let fchown fd perm = invalid_arg "Unix.fchown not implemented"
-let umask msk = invalid_arg "Unix.umask not implemented"
+let fchmod _fd _perm = invalid_arg "Unix.fchmod not implemented"
+let chown _file _perm = invalid_arg "Unix.chown not implemented"
+let fchown _fd _perm = invalid_arg "Unix.fchown not implemented"
+let umask _msk = invalid_arg "Unix.umask not implemented"
 
 external access : string -> access_permission list -> unit = "unix_access"
 
@@ -371,7 +371,7 @@ let rewinddir d =
 
 external pipe : unit -> file_descr * file_descr = "unix_pipe"
 
-let mkfifo name perm = invalid_arg "Unix.mkfifo not implemented"
+let mkfifo _name _perm = invalid_arg "Unix.mkfifo not implemented"
 
 (* Symbolic links *)
 
@@ -416,9 +416,9 @@ let kill pid signo =
         (* could be more precise *)
 
 type sigprocmask_command = SIG_SETMASK | SIG_BLOCK | SIG_UNBLOCK
-let sigprocmask cmd sigs = invalid_arg "Unix.sigprocmask not implemented"
+let sigprocmask _cmd _sigs = invalid_arg "Unix.sigprocmask not implemented"
 let sigpending () = invalid_arg "Unix.sigpending not implemented"
-let sigsuspend sigs = invalid_arg "Unix.sigsuspend not implemented"
+let sigsuspend _sigs = invalid_arg "Unix.sigsuspend not implemented"
 let pause () = invalid_arg "Unix.pause not implemented"
 
 (* Time functions *)
@@ -445,7 +445,7 @@ external gettimeofday : unit -> float = "unix_gettimeofday"
 external gmtime : float -> tm = "unix_gmtime"
 external localtime : float -> tm = "unix_localtime"
 external mktime : tm -> float * tm = "unix_mktime"
-let alarm n = invalid_arg "Unix.alarm not implemented"
+let alarm _n = invalid_arg "Unix.alarm not implemented"
 external sleepf : float -> unit = "unix_sleep"
 let sleep n = sleepf (float n)
 external times: unit -> process_times = "unix_times"
@@ -460,18 +460,18 @@ type interval_timer_status =
   { it_interval: float;
     it_value: float }
 
-let getitimer it = invalid_arg "Unix.getitimer not implemented"
-let setitimer it tm = invalid_arg "Unix.setitimer not implemented"
+let getitimer _it = invalid_arg "Unix.getitimer not implemented"
+let setitimer _it _tm = invalid_arg "Unix.setitimer not implemented"
 
 (* User id, group id *)
 
 let getuid () = 1
 let geteuid = getuid
-let setuid id = invalid_arg "Unix.setuid not implemented"
+let setuid _id = invalid_arg "Unix.setuid not implemented"
 
 let getgid () = 1
 let getegid = getgid
-let setgid id = invalid_arg "Unix.setgid not implemented"
+let setgid _id = invalid_arg "Unix.setgid not implemented"
 
 let getgroups () = [|1|]
 let setgroups _ = invalid_arg "Unix.setgroups not implemented"
@@ -493,7 +493,7 @@ type group_entry =
     gr_mem : string array }
 
 let getlogin () = try Sys.getenv "USERNAME" with Not_found -> ""
-let getpwnam x = raise Not_found
+let getpwnam _x = raise Not_found
 let getgrnam = getpwnam
 let getpwuid = getpwnam
 let getgrgid = getpwnam
@@ -549,7 +549,7 @@ type msg_flag =
 
 external socket : socket_domain -> socket_type -> int -> file_descr
                                   = "unix_socket"
-let socketpair dom ty proto = invalid_arg "Unix.socketpair not implemented"
+let socketpair _dom _ty _proto = invalid_arg "Unix.socketpair not implemented"
 external accept : file_descr -> file_descr * sockaddr = "unix_accept"
 external bind : file_descr -> sockaddr -> unit = "unix_bind"
 external connect : file_descr -> sockaddr -> unit = "unix_connect"
@@ -958,7 +958,7 @@ let open_connection sockaddr =
 let shutdown_connection inchan =
   shutdown (descr_of_in_channel inchan) SHUTDOWN_SEND
 
-let establish_server server_fun sockaddr =
+let establish_server _server_fun _sockaddr =
   invalid_arg "Unix.establish_server not implemented"
 
 (* Terminal interface *)
@@ -1006,13 +1006,13 @@ type terminal_io = {
 
 type setattr_when = TCSANOW | TCSADRAIN | TCSAFLUSH
 
-let tcgetattr fd = invalid_arg "Unix.tcgetattr not implemented"
-let tcsetattr fd wh = invalid_arg "Unix.tcsetattr not implemented"
-let tcsendbreak fd n = invalid_arg "Unix.tcsendbreak not implemented"
-let tcdrain fd = invalid_arg "Unix.tcdrain not implemented"
+let tcgetattr _fd = invalid_arg "Unix.tcgetattr not implemented"
+let tcsetattr _fd _wh = invalid_arg "Unix.tcsetattr not implemented"
+let tcsendbreak _fd _n = invalid_arg "Unix.tcsendbreak not implemented"
+let tcdrain _fd = invalid_arg "Unix.tcdrain not implemented"
 
 type flush_queue = TCIFLUSH | TCOFLUSH | TCIOFLUSH
-let tcflush fd q = invalid_arg "Unix.tcflush not implemented"
+let tcflush _fd _q = invalid_arg "Unix.tcflush not implemented"
 type flow_action = TCOOFF | TCOON | TCIOFF | TCION
-let tcflow fd fl = invalid_arg "Unix.tcflow not implemented"
+let tcflow _fd _fl = invalid_arg "Unix.tcflow not implemented"
 let setsid () = invalid_arg "Unix.setsid not implemented"
diff --git a/otherlibs/win32unix/windbug.h b/otherlibs/win32unix/windbug.h
index 8427ebfc..cc5ee690 100644
--- a/otherlibs/win32unix/windbug.h
+++ b/otherlibs/win32unix/windbug.h
@@ -37,6 +37,34 @@
 /* Test if we are in dbug mode */
 int  debug_test    (void);
 
+#elif defined(_MSC_VER) && _MSC_VER < 1300
+
+#define DEBUG_PRINT(fmt)
+
+/* __pragma wasn't added until Visual C++ .NET 2002, so simply disable the
+   warning entirely
+ */
+
+#pragma warning (disable:4002)
+
+#elif defined(_MSC_VER) && _MSC_VER <= 1400
+
+/* Not all versions of the Visual Studio 2005 C Compiler (Version 14) support
+   variadic macros, hence the test for this branch being <= 1400 rather than
+   < 1400.
+   This convoluted pair of macros allow DEBUG_PRINT to remain while temporarily
+   suppressing the warning displayed for a macro called with too many
+   parameters.
+ */
+#define DEBUG_PRINT_S(fmt) __pragma(warning(pop))
+#define DEBUG_PRINT \
+  __pragma(warning(push)) \
+  __pragma(warning(disable:4002)) \
+  DEBUG_PRINT_S
+
 #else
+
+/* Visual Studio supports variadic macros in all versions from 2008 (CL 15). */
 #define DEBUG_PRINT(fmt, ...)
+
 #endif
diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml
index e3bf483d..82db57bd 100644
--- a/parsing/ast_helper.ml
+++ b/parsing/ast_helper.ml
@@ -87,6 +87,7 @@ module Pat = struct
   let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a)
   let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a)
   let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a)
+  let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b))
   let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a)
   let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a)
 end
@@ -122,6 +123,7 @@ module Exp = struct
   let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b))
   let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a)
   let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c))
+  let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b))
   let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a)
   let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a)
   let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b))
@@ -186,9 +188,10 @@ module Sig = struct
   let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs))
   let attribute ?loc a = mk ?loc (Psig_attribute a)
   let text txt =
+    let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
     List.map
       (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
-      txt
+      f_txt
 end
 
 module Str = struct
@@ -210,9 +213,10 @@ module Str = struct
   let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs))
   let attribute ?loc a = mk ?loc (Pstr_attribute a)
   let text txt =
+    let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
     List.map
       (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
-      txt
+      f_txt
 end
 
 module Cl = struct
@@ -264,9 +268,10 @@ module Ctf = struct
   let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a)
   let attribute ?loc a = mk ?loc (Pctf_attribute a)
   let text txt =
-    List.map
+   let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
+     List.map
       (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
-      txt
+      f_txt
 
   let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]}
 
@@ -289,9 +294,10 @@ module Cf = struct
   let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a)
   let attribute ?loc a = mk ?loc (Pcf_attribute a)
   let text txt =
+    let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
     List.map
       (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
-      txt
+      f_txt
 
   let virtual_ ct = Cfk_virtual ct
   let concrete o e = Cfk_concrete (o, e)
diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli
index 6a527feb..dc5d0dcc 100644
--- a/parsing/ast_helper.mli
+++ b/parsing/ast_helper.mli
@@ -97,6 +97,7 @@ module Pat:
     val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern
     val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern
     val unpack: ?loc:loc -> ?attrs:attrs -> str -> pattern
+    val open_: ?loc:loc -> ?attrs:attrs  -> lid -> pattern -> pattern
     val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern
     val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern
   end
@@ -149,6 +150,9 @@ module Exp:
                   -> expression
     val letmodule: ?loc:loc -> ?attrs:attrs -> str -> module_expr -> expression
                    -> expression
+    val letexception:
+      ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression
+      -> expression
     val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression
     val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression
     val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option
@@ -306,21 +310,20 @@ module Mb:
       str -> module_expr -> module_binding
   end
 
-(* Opens *)
+(** Opens *)
 module Opn:
   sig
     val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs ->
       ?override:override_flag -> lid -> open_description
   end
 
-(* Includes *)
+(** Includes *)
 module Incl:
   sig
     val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos
   end
 
 (** Value bindings *)
-
 module Vb:
   sig
     val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
diff --git a/parsing/ast_iterator.ml b/parsing/ast_iterator.ml
index 2f8798a5..8518438d 100755
--- a/parsing/ast_iterator.ml
+++ b/parsing/ast_iterator.ml
@@ -98,13 +98,13 @@ module T = struct
     | 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) ->
+    | 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) ->
+    | Ptyp_variant (rl, _b, _ll) ->
         List.iter (row_field sub) rl
     | Ptyp_poly (_, t) -> sub.typ sub t
     | Ptyp_package (lid, l) ->
@@ -115,7 +115,7 @@ module T = struct
   let iter_type_declaration sub
       {ptype_name; ptype_params; ptype_cstrs;
        ptype_kind;
-       ptype_private;
+       ptype_private = _;
        ptype_manifest;
        ptype_attributes;
        ptype_loc} =
@@ -144,7 +144,7 @@ module T = struct
   let iter_type_extension sub
       {ptyext_path; ptyext_params;
        ptyext_constructors;
-       ptyext_private;
+       ptyext_private = _;
        ptyext_attributes} =
     iter_loc sub ptyext_path;
     List.iter (sub.extension_constructor sub) ptyext_constructors;
@@ -189,8 +189,8 @@ module CT = struct
     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_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
@@ -234,7 +234,7 @@ module MT = struct
     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_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
@@ -277,9 +277,9 @@ module M = struct
     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_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_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
@@ -303,11 +303,11 @@ module E = struct
     sub.attributes sub attrs;
     match desc with
     | Pexp_ident x -> iter_loc sub x
-    | Pexp_constant x -> ()
-    | Pexp_let (r, vbs, e) ->
+    | Pexp_constant _ -> ()
+    | Pexp_let (_r, vbs, e) ->
         List.iter (sub.value_binding sub) vbs;
         sub.expr sub e
-    | Pexp_fun (lab, def, p, e) ->
+    | Pexp_fun (_lab, def, p, e) ->
         iter_opt (sub.expr sub) def;
         sub.pat sub p;
         sub.expr sub e
@@ -320,7 +320,7 @@ module E = struct
     | 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) ->
+    | 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;
@@ -338,7 +338,7 @@ module E = struct
         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) ->
+    | 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) ->
@@ -346,7 +346,7 @@ module E = struct
         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_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
@@ -355,14 +355,17 @@ module E = struct
     | Pexp_letmodule (s, me, e) ->
         iter_loc sub s; sub.module_expr sub me;
         sub.expr sub e
+    | Pexp_letexception (cd, e) ->
+        sub.extension_constructor sub cd;
+        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_newtype (_s, e) -> sub.expr sub e
     | Pexp_pack me -> sub.module_expr sub me
-    | Pexp_open (ovf, lid, e) ->
+    | Pexp_open (_ovf, lid, e) ->
         iter_loc sub lid; sub.expr sub e
     | Pexp_extension x -> sub.extension sub x
     | Pexp_unreachable -> ()
@@ -378,13 +381,13 @@ module P = struct
     | 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_constant _ -> ()
+    | Ppat_interval _ -> ()
     | 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) ->
+    | 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
@@ -395,6 +398,9 @@ module P = struct
     | Ppat_unpack s -> iter_loc sub s
     | Ppat_exception p -> sub.pat sub p
     | Ppat_extension x -> sub.extension sub x
+    | Ppat_open (lid, p) ->
+        iter_loc sub lid; sub.pat sub p
+
 end
 
 module CE = struct
@@ -408,14 +414,14 @@ module CE = struct
         iter_loc sub lid; List.iter (sub.typ sub) tys
     | Pcl_structure s ->
         sub.class_structure sub s
-    | Pcl_fun (lab, e, p, ce) ->
+    | 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) ->
+    | Pcl_let (_r, vbs, ce) ->
         List.iter (sub.value_binding sub) vbs;
         sub.class_expr sub ce
     | Pcl_constraint (ce, ct) ->
@@ -423,16 +429,16 @@ module CE = struct
     | Pcl_extension x -> sub.extension sub x
 
   let iter_kind sub = function
-    | Cfk_concrete (o, e) -> sub.expr sub e
+    | 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) ->
+    | 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
@@ -444,7 +450,7 @@ module CE = struct
     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;
+  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;
@@ -484,7 +490,7 @@ let default_iterator =
     type_extension = T.iter_type_extension;
     extension_constructor = T.iter_extension_constructor;
     value_description =
-      (fun this {pval_name; pval_type; pval_prim; pval_loc;
+      (fun this {pval_name; pval_type; pval_prim = _; pval_loc;
                  pval_attributes} ->
         iter_loc this pval_name;
         this.typ this pval_type;
@@ -520,7 +526,7 @@ let default_iterator =
 
 
     open_description =
-      (fun this {popen_lid; popen_override; popen_attributes; popen_loc} ->
+      (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
@@ -561,7 +567,7 @@ let default_iterator =
       );
 
     label_declaration =
-      (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} ->
+      (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;
@@ -576,7 +582,7 @@ let default_iterator =
          this.expr this pc_rhs
       );
 
-    location = (fun this l -> ());
+    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);
diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml
index 8b72b496..ec409be9 100644
--- a/parsing/ast_mapper.ml
+++ b/parsing/ast_mapper.ml
@@ -370,6 +370,10 @@ module E = struct
     | Pexp_letmodule (s, me, e) ->
         letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me)
           (sub.expr sub e)
+    | Pexp_letexception (cd, e) ->
+        letexception ~loc ~attrs
+          (sub.extension_constructor sub cd)
+          (sub.expr sub e)
     | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e)
     | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e)
     | Pexp_poly (e, t) ->
@@ -410,6 +414,7 @@ module P = struct
     | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s)
     | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p)
     | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s)
+    | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p)
     | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p)
     | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x)
 end
@@ -613,7 +618,7 @@ let default_mapper =
 
 
 
-    location = (fun this l -> l);
+    location = (fun _this l -> l);
 
     extension = (fun this (s, e) -> (map_loc this s, this.payload this e));
     attribute = (fun this (s, e) -> (map_loc this s, this.payload this e));
diff --git a/parsing/asttypes.mli b/parsing/asttypes.mli
index 5188b69c..8cab1c6b 100644
--- a/parsing/asttypes.mli
+++ b/parsing/asttypes.mli
@@ -13,7 +13,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(* Auxiliary a.s.t. types used by parsetree and typedtree. *)
+(** Auxiliary AST types used by parsetree and typedtree. *)
 
 type constant =
     Const_int of int
diff --git a/parsing/builtin_attributes.ml b/parsing/builtin_attributes.ml
index 9e452ce1..bdbefcdf 100755
--- a/parsing/builtin_attributes.ml
+++ b/parsing/builtin_attributes.ml
@@ -32,7 +32,7 @@ let rec error_of_extension ext =
       match inner with
       | {pstr_desc=Pstr_extension (ext, _)} :: rest ->
           error_of_extension ext :: sub_from rest
-      | {pstr_loc} :: rest ->
+      | _ :: rest ->
           (Location.errorf ~loc
              "Invalid syntax for sub-error of extension '%s'." txt) ::
             sub_from rest
@@ -188,3 +188,26 @@ let explicit_arity =
       | ({txt="ocaml.explicit_arity"|"explicit_arity"; _}, _) -> true
       | _ -> false
     )
+
+let immediate =
+  List.exists
+    (function
+      | ({txt="ocaml.immediate"|"immediate"; _}, _) -> true
+      | _ -> false
+    )
+
+(* The "ocaml.boxed (default)" and "ocaml.unboxed (default)"
+   attributes cannot be input by the user, they are added by the
+   compiler when applying the default setting. This is done to record
+   in the .cmi the default used by the compiler when compiling the
+   source file because the default can change between compiler
+   invocations. *)
+
+let check l (x, _) = List.mem x.txt l
+
+let has_unboxed attr =
+  List.exists (check ["ocaml.unboxed"; "unboxed"])
+    attr
+
+let has_boxed attr =
+  List.exists (check ["ocaml.boxed"; "boxed"]) attr
diff --git a/parsing/builtin_attributes.mli b/parsing/builtin_attributes.mli
index 60b709a8..9add6373 100755
--- a/parsing/builtin_attributes.mli
+++ b/parsing/builtin_attributes.mli
@@ -23,6 +23,8 @@
    ocaml.explicit_arity (for camlp4/camlp5)
    ocaml.warn_on_literal_pattern
    ocaml.deprecated_mutable
+   ocaml.immediate
+   ocaml.boxed / ocaml.unboxed
 *)
 
 
@@ -45,3 +47,9 @@ val emit_external_warnings: Ast_iterator.iterator
 
 val warn_on_literal_pattern: Parsetree.attributes -> bool
 val explicit_arity: Parsetree.attributes -> bool
+
+
+val immediate: Parsetree.attributes -> bool
+
+val has_unboxed: Parsetree.attributes -> bool
+val has_boxed: Parsetree.attributes -> bool
diff --git a/parsing/depend.ml b/parsing/depend.ml
new file mode 100644
index 00000000..8703ffe0
--- /dev/null
+++ b/parsing/depend.ml
@@ -0,0 +1,517 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Location
+open Longident
+open Parsetree
+
+module StringSet = Set.Make(struct type t = string let compare = compare end)
+module StringMap = Map.Make(String)
+
+(* Module resolution map *)
+(* Node (set of imports for this path, map for submodules) *)
+type map_tree = Node of StringSet.t * bound_map
+and  bound_map = map_tree StringMap.t
+let bound = Node (StringSet.empty, StringMap.empty)
+
+(*let get_free (Node (s, _m)) = s*)
+let get_map (Node (_s, m)) = m
+let make_leaf s = Node (StringSet.singleton s, StringMap.empty)
+let make_node m =  Node (StringSet.empty, m)
+let rec weaken_map s (Node(s0,m0)) =
+  Node (StringSet.union s s0, StringMap.map (weaken_map s) m0)
+let rec collect_free (Node (s, m)) =
+  StringMap.fold (fun _ n -> StringSet.union (collect_free n)) m s
+
+(* Returns the imports required to access the structure at path p *)
+(* Only raises Not_found if the head of p is not in the toplevel map *)
+let rec lookup_free p m =
+  match p with
+    [] -> raise Not_found
+  | s::p ->
+      let Node (f, m') = StringMap.find s m  in
+      try lookup_free p m' with Not_found -> f
+
+(* Returns the node corresponding to the structure at path p *)
+let rec lookup_map lid m =
+  match lid with
+    Lident s    -> StringMap.find s m
+  | Ldot (l, s) -> StringMap.find s (get_map (lookup_map l m))
+  | Lapply _    -> raise Not_found
+
+(* Collect free module identifiers in the a.s.t. *)
+
+let free_structure_names = ref StringSet.empty
+
+let add_names s =
+  free_structure_names := StringSet.union s !free_structure_names
+
+let rec add_path bv ?(p=[]) = function
+  | Lident s ->
+      let free =
+        try lookup_free (s::p) bv with Not_found -> StringSet.singleton s
+      in
+      (*StringSet.iter (fun s -> Printf.eprintf "%s " s) free;
+        prerr_endline "";*)
+      add_names free
+  | Ldot(l, s) -> add_path bv ~p:(s::p) l
+  | Lapply(l1, l2) -> add_path bv l1; add_path bv l2
+
+let open_module bv lid =
+  match lookup_map lid bv with
+  | Node (s, m) ->
+      add_names s;
+      StringMap.fold StringMap.add m bv
+  | exception Not_found ->
+      add_path bv lid; bv
+
+let add_parent bv lid =
+  match lid.txt with
+    Ldot(l, _s) -> add_path bv l
+  | _ -> ()
+
+let add = add_parent
+
+let addmodule bv lid = add_path bv lid.txt
+
+let handle_extension ext =
+  match (fst ext).txt with
+  | "error" | "ocaml.error" ->
+    raise (Location.Error
+             (Builtin_attributes.error_of_extension ext))
+  | _ ->
+    ()
+
+let rec add_type bv ty =
+  match ty.ptyp_desc with
+    Ptyp_any -> ()
+  | Ptyp_var _ -> ()
+  | Ptyp_arrow(_, t1, t2) -> add_type bv t1; add_type bv t2
+  | Ptyp_tuple tl -> List.iter (add_type bv) tl
+  | Ptyp_constr(c, tl) -> add bv c; List.iter (add_type bv) tl
+  | Ptyp_object (fl, _) -> List.iter (fun (_, _, t) -> add_type bv t) fl
+  | Ptyp_class(c, tl) -> add bv c; List.iter (add_type bv) tl
+  | Ptyp_alias(t, _) -> add_type bv t
+  | Ptyp_variant(fl, _, _) ->
+      List.iter
+        (function Rtag(_,_,_,stl) -> List.iter (add_type bv) stl
+          | Rinherit sty -> add_type bv sty)
+        fl
+  | Ptyp_poly(_, t) -> add_type bv t
+  | Ptyp_package pt -> add_package_type bv pt
+  | Ptyp_extension e -> handle_extension e
+
+and add_package_type bv (lid, l) =
+  add bv lid;
+  List.iter (add_type bv) (List.map (fun (_, e) -> e) l)
+
+let add_opt add_fn bv = function
+    None -> ()
+  | Some x -> add_fn bv x
+
+let add_constructor_arguments bv = function
+  | Pcstr_tuple l -> List.iter (add_type bv) l
+  | Pcstr_record l -> List.iter (fun l -> add_type bv l.pld_type) l
+
+let add_constructor_decl bv pcd =
+  add_constructor_arguments bv pcd.pcd_args;
+  Misc.may (add_type bv) pcd.pcd_res
+
+let add_type_declaration bv td =
+  List.iter
+    (fun (ty1, ty2, _) -> add_type bv ty1; add_type bv ty2)
+    td.ptype_cstrs;
+  add_opt add_type bv td.ptype_manifest;
+  let add_tkind = function
+    Ptype_abstract -> ()
+  | Ptype_variant cstrs ->
+      List.iter (add_constructor_decl bv) cstrs
+  | Ptype_record lbls ->
+      List.iter (fun pld -> add_type bv pld.pld_type) lbls
+  | Ptype_open -> () in
+  add_tkind td.ptype_kind
+
+let add_extension_constructor bv ext =
+  match ext.pext_kind with
+    Pext_decl(args, rty) ->
+      add_constructor_arguments bv args;
+      Misc.may (add_type bv) rty
+  | Pext_rebind lid -> add bv lid
+
+let add_type_extension bv te =
+  add bv te.ptyext_path;
+  List.iter (add_extension_constructor bv) te.ptyext_constructors
+
+let rec add_class_type bv cty =
+  match cty.pcty_desc with
+    Pcty_constr(l, tyl) ->
+      add bv l; List.iter (add_type bv) tyl
+  | Pcty_signature { pcsig_self = ty; pcsig_fields = fieldl } ->
+      add_type bv ty;
+      List.iter (add_class_type_field bv) fieldl
+  | Pcty_arrow(_, ty1, cty2) ->
+      add_type bv ty1; add_class_type bv cty2
+  | Pcty_extension e -> handle_extension e
+
+and add_class_type_field bv pctf =
+  match pctf.pctf_desc with
+    Pctf_inherit cty -> add_class_type bv cty
+  | Pctf_val(_, _, _, ty) -> add_type bv ty
+  | Pctf_method(_, _, _, ty) -> add_type bv ty
+  | Pctf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2
+  | Pctf_attribute _ -> ()
+  | Pctf_extension e -> handle_extension e
+
+let add_class_description bv infos =
+  add_class_type bv infos.pci_expr
+
+let add_class_type_declaration = add_class_description
+
+let pattern_bv = ref StringMap.empty
+
+let rec add_pattern bv pat =
+  match pat.ppat_desc with
+    Ppat_any -> ()
+  | Ppat_var _ -> ()
+  | Ppat_alias(p, _) -> add_pattern bv p
+  | Ppat_interval _
+  | Ppat_constant _ -> ()
+  | Ppat_tuple pl -> List.iter (add_pattern bv) pl
+  | Ppat_construct(c, op) -> add bv c; add_opt add_pattern bv op
+  | Ppat_record(pl, _) ->
+      List.iter (fun (lbl, p) -> add bv lbl; add_pattern bv p) pl
+  | Ppat_array pl -> List.iter (add_pattern bv) pl
+  | Ppat_or(p1, p2) -> add_pattern bv p1; add_pattern bv p2
+  | Ppat_constraint(p, ty) -> add_pattern bv p; add_type bv ty
+  | Ppat_variant(_, op) -> add_opt add_pattern bv op
+  | Ppat_type li -> add bv li
+  | Ppat_lazy p -> add_pattern bv p
+  | Ppat_unpack id -> pattern_bv := StringMap.add id.txt bound !pattern_bv
+  | Ppat_open ( m, p) -> let bv = open_module bv m.txt in add_pattern bv p
+  | Ppat_exception p -> add_pattern bv p
+  | Ppat_extension e -> handle_extension e
+
+let add_pattern bv pat =
+  pattern_bv := bv;
+  add_pattern bv pat;
+  !pattern_bv
+
+let rec add_expr bv exp =
+  match exp.pexp_desc with
+    Pexp_ident l -> add bv l
+  | Pexp_constant _ -> ()
+  | Pexp_let(rf, pel, e) ->
+      let bv = add_bindings rf bv pel in add_expr bv e
+  | Pexp_fun (_, opte, p, e) ->
+      add_opt add_expr bv opte; add_expr (add_pattern bv p) e
+  | Pexp_function pel ->
+      add_cases bv pel
+  | Pexp_apply(e, el) ->
+      add_expr bv e; List.iter (fun (_,e) -> add_expr bv e) el
+  | Pexp_match(e, pel) -> add_expr bv e; add_cases bv pel
+  | Pexp_try(e, pel) -> add_expr bv e; add_cases bv pel
+  | Pexp_tuple el -> List.iter (add_expr bv) el
+  | Pexp_construct(c, opte) -> add bv c; add_opt add_expr bv opte
+  | Pexp_variant(_, opte) -> add_opt add_expr bv opte
+  | Pexp_record(lblel, opte) ->
+      List.iter (fun (lbl, e) -> add bv lbl; add_expr bv e) lblel;
+      add_opt add_expr bv opte
+  | Pexp_field(e, fld) -> add_expr bv e; add bv fld
+  | Pexp_setfield(e1, fld, e2) -> add_expr bv e1; add bv fld; add_expr bv e2
+  | Pexp_array el -> List.iter (add_expr bv) el
+  | Pexp_ifthenelse(e1, e2, opte3) ->
+      add_expr bv e1; add_expr bv e2; add_opt add_expr bv opte3
+  | Pexp_sequence(e1, e2) -> add_expr bv e1; add_expr bv e2
+  | Pexp_while(e1, e2) -> add_expr bv e1; add_expr bv e2
+  | Pexp_for( _, e1, e2, _, e3) ->
+      add_expr bv e1; add_expr bv e2; add_expr bv e3
+  | Pexp_coerce(e1, oty2, ty3) ->
+      add_expr bv e1;
+      add_opt add_type bv oty2;
+      add_type bv ty3
+  | Pexp_constraint(e1, ty2) ->
+      add_expr bv e1;
+      add_type bv ty2
+  | Pexp_send(e, _m) -> add_expr bv e
+  | Pexp_new li -> add bv li
+  | Pexp_setinstvar(_v, e) -> add_expr bv e
+  | Pexp_override sel -> List.iter (fun (_s, e) -> add_expr bv e) sel
+  | Pexp_letmodule(id, m, e) ->
+      let b = add_module_binding bv m in
+      add_expr (StringMap.add id.txt b bv) e
+  | Pexp_letexception(_, e) -> add_expr bv e
+  | Pexp_assert (e) -> add_expr bv e
+  | Pexp_lazy (e) -> add_expr bv e
+  | Pexp_poly (e, t) -> add_expr bv e; add_opt add_type bv t
+  | Pexp_object { pcstr_self = pat; pcstr_fields = fieldl } ->
+      let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl
+  | Pexp_newtype (_, e) -> add_expr bv e
+  | Pexp_pack m -> add_module bv m
+  | Pexp_open (_ovf, m, e) ->
+      let bv = open_module bv m.txt in add_expr bv e
+  | Pexp_extension (({ txt = ("ocaml.extension_constructor"|
+                              "extension_constructor"); _ },
+                     PStr [item]) as e) ->
+      begin match item.pstr_desc with
+      | Pstr_eval ({ pexp_desc = Pexp_construct (c, None) }, _) -> add bv c
+      | _ -> handle_extension e
+      end
+  | Pexp_extension e -> handle_extension e
+  | Pexp_unreachable -> ()
+
+and add_cases bv cases =
+  List.iter (add_case bv) cases
+
+and add_case bv {pc_lhs; pc_guard; pc_rhs} =
+  let bv = add_pattern bv pc_lhs in
+  add_opt add_expr bv pc_guard;
+  add_expr bv pc_rhs
+
+and add_bindings recf bv pel =
+  let bv' = List.fold_left (fun bv x -> add_pattern bv x.pvb_pat) bv pel in
+  let bv = if recf = Recursive then bv' else bv in
+  List.iter (fun x -> add_expr bv x.pvb_expr) pel;
+  bv'
+
+and add_modtype bv mty =
+  match mty.pmty_desc with
+    Pmty_ident l -> add bv l
+  | Pmty_alias l -> addmodule bv l
+  | Pmty_signature s -> add_signature bv s
+  | Pmty_functor(id, mty1, mty2) ->
+      Misc.may (add_modtype bv) mty1;
+      add_modtype (StringMap.add id.txt bound bv) mty2
+  | Pmty_with(mty, cstrl) ->
+      add_modtype bv mty;
+      List.iter
+        (function
+          | Pwith_type (_, td) -> add_type_declaration bv td
+          | Pwith_module (_, lid) -> addmodule bv lid
+          | Pwith_typesubst td -> add_type_declaration bv td
+          | Pwith_modsubst (_, lid) -> addmodule bv lid
+        )
+        cstrl
+  | Pmty_typeof m -> add_module bv m
+  | Pmty_extension e -> handle_extension e
+
+and add_module_alias bv l =
+  try
+    add_parent bv l;
+    lookup_map l.txt bv
+  with Not_found ->
+    match l.txt with
+      Lident s -> make_leaf s
+    | _ -> addmodule bv l; bound (* cannot delay *)
+
+and add_modtype_binding bv mty =
+  if not !Clflags.transparent_modules then add_modtype bv mty;
+  match mty.pmty_desc with
+    Pmty_alias l ->
+      add_module_alias bv l
+  | Pmty_signature s ->
+      make_node (add_signature_binding bv s)
+  | Pmty_typeof modl ->
+      add_module_binding bv modl
+  | _ ->
+      if !Clflags.transparent_modules then add_modtype bv mty; bound
+
+and add_signature bv sg =
+  ignore (add_signature_binding bv sg)
+
+and add_signature_binding bv sg =
+  snd (List.fold_left add_sig_item (bv, StringMap.empty) sg)
+
+and add_sig_item (bv, m) item =
+  match item.psig_desc with
+    Psig_value vd ->
+      add_type bv vd.pval_type; (bv, m)
+  | Psig_type (_, dcls) ->
+      List.iter (add_type_declaration bv) dcls; (bv, m)
+  | Psig_typext te ->
+      add_type_extension bv te; (bv, m)
+  | Psig_exception pext ->
+      add_extension_constructor bv pext; (bv, m)
+  | Psig_module pmd ->
+      let m' = add_modtype_binding bv pmd.pmd_type in
+      let add = StringMap.add pmd.pmd_name.txt m' in
+      (add bv, add m)
+  | Psig_recmodule decls ->
+      let add =
+        List.fold_right (fun pmd -> StringMap.add pmd.pmd_name.txt bound)
+                        decls
+      in
+      let bv' = add bv and m' = add m in
+      List.iter (fun pmd -> add_modtype bv' pmd.pmd_type) decls;
+      (bv', m')
+  | Psig_modtype x ->
+      begin match x.pmtd_type with
+        None -> ()
+      | Some mty -> add_modtype bv mty
+      end;
+      (bv, m)
+  | Psig_open od ->
+      (open_module bv od.popen_lid.txt, m)
+  | Psig_include incl ->
+      let Node (s, m') = add_modtype_binding bv incl.pincl_mod in
+      add_names s;
+      let add = StringMap.fold StringMap.add m' in
+      (add bv, add m)
+  | Psig_class cdl ->
+      List.iter (add_class_description bv) cdl; (bv, m)
+  | Psig_class_type cdtl ->
+      List.iter (add_class_type_declaration bv) cdtl; (bv, m)
+  | Psig_attribute _ -> (bv, m)
+  | Psig_extension (e, _) ->
+      handle_extension e;
+      (bv, m)
+
+and add_module_binding bv modl =
+  if not !Clflags.transparent_modules then add_module bv modl;
+  match modl.pmod_desc with
+    Pmod_ident l ->
+      begin try
+        add_parent bv l;
+        lookup_map l.txt bv
+      with Not_found ->
+        match l.txt with
+          Lident s -> make_leaf s
+        | _ ->  addmodule bv l; bound
+      end
+  | Pmod_structure s ->
+      make_node (snd (add_structure_binding bv s))
+  | _ ->
+      if !Clflags.transparent_modules then add_module bv modl; bound
+
+and add_module bv modl =
+  match modl.pmod_desc with
+    Pmod_ident l -> addmodule bv l
+  | Pmod_structure s -> ignore (add_structure bv s)
+  | Pmod_functor(id, mty, modl) ->
+      Misc.may (add_modtype bv) mty;
+      add_module (StringMap.add id.txt bound bv) modl
+  | Pmod_apply(mod1, mod2) ->
+      add_module bv mod1; add_module bv mod2
+  | Pmod_constraint(modl, mty) ->
+      add_module bv modl; add_modtype bv mty
+  | Pmod_unpack(e) ->
+      add_expr bv e
+  | Pmod_extension e ->
+      handle_extension e
+
+and add_structure bv item_list =
+  let (bv, m) = add_structure_binding bv item_list in
+  add_names (collect_free (make_node m));
+  bv
+
+and add_structure_binding bv item_list =
+  List.fold_left add_struct_item (bv, StringMap.empty) item_list
+
+and add_struct_item (bv, m) item : _ StringMap.t * _ StringMap.t =
+  match item.pstr_desc with
+    Pstr_eval (e, _attrs) ->
+      add_expr bv e; (bv, m)
+  | Pstr_value(rf, pel) ->
+      let bv = add_bindings rf bv pel in (bv, m)
+  | Pstr_primitive vd ->
+      add_type bv vd.pval_type; (bv, m)
+  | Pstr_type (_, dcls) ->
+      List.iter (add_type_declaration bv) dcls; (bv, m)
+  | Pstr_typext te ->
+      add_type_extension bv te;
+      (bv, m)
+  | Pstr_exception pext ->
+      add_extension_constructor bv pext; (bv, m)
+  | Pstr_module x ->
+      let b = add_module_binding bv x.pmb_expr in
+      let add = StringMap.add x.pmb_name.txt b in
+      (add bv, add m)
+  | Pstr_recmodule bindings ->
+      let add =
+        List.fold_right (fun x -> StringMap.add x.pmb_name.txt bound) bindings
+      in
+      let bv' = add bv and m = add m in
+      List.iter
+        (fun x -> add_module bv' x.pmb_expr)
+        bindings;
+      (bv', m)
+  | Pstr_modtype x ->
+      begin match x.pmtd_type with
+        None -> ()
+      | Some mty -> add_modtype bv mty
+      end;
+      (bv, m)
+  | Pstr_open od ->
+      (open_module bv od.popen_lid.txt, m)
+  | Pstr_class cdl ->
+      List.iter (add_class_declaration bv) cdl; (bv, m)
+  | Pstr_class_type cdtl ->
+      List.iter (add_class_type_declaration bv) cdtl; (bv, m)
+  | Pstr_include incl ->
+      let Node (s, m') = add_module_binding bv incl.pincl_mod in
+      add_names s;
+      let add = StringMap.fold StringMap.add m' in
+      (add bv, add m)
+  | Pstr_attribute _ -> (bv, m)
+  | Pstr_extension (e, _) ->
+      handle_extension e;
+      (bv, m)
+
+and add_use_file bv top_phrs =
+  ignore (List.fold_left add_top_phrase bv top_phrs)
+
+and add_implementation bv l =
+  if !Clflags.transparent_modules then
+    ignore (add_structure_binding bv l)
+  else ignore (add_structure bv l)
+
+and add_implementation_binding bv l =
+  snd (add_structure_binding bv l)
+
+and add_top_phrase bv = function
+  | Ptop_def str -> add_structure bv str
+  | Ptop_dir (_, _) -> bv
+
+and add_class_expr bv ce =
+  match ce.pcl_desc with
+    Pcl_constr(l, tyl) ->
+      add bv l; List.iter (add_type bv) tyl
+  | Pcl_structure { pcstr_self = pat; pcstr_fields = fieldl } ->
+      let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl
+  | Pcl_fun(_, opte, pat, ce) ->
+      add_opt add_expr bv opte;
+      let bv = add_pattern bv pat in add_class_expr bv ce
+  | Pcl_apply(ce, exprl) ->
+      add_class_expr bv ce; List.iter (fun (_,e) -> add_expr bv e) exprl
+  | Pcl_let(rf, pel, ce) ->
+      let bv = add_bindings rf bv pel in add_class_expr bv ce
+  | Pcl_constraint(ce, ct) ->
+      add_class_expr bv ce; add_class_type bv ct
+  | Pcl_extension e -> handle_extension e
+
+and add_class_field bv pcf =
+  match pcf.pcf_desc with
+    Pcf_inherit(_, ce, _) -> add_class_expr bv ce
+  | Pcf_val(_, _, Cfk_concrete (_, e))
+  | Pcf_method(_, _, Cfk_concrete (_, e)) -> add_expr bv e
+  | Pcf_val(_, _, Cfk_virtual ty)
+  | Pcf_method(_, _, Cfk_virtual ty) -> add_type bv ty
+  | Pcf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2
+  | Pcf_initializer e -> add_expr bv e
+  | Pcf_attribute _ -> ()
+  | Pcf_extension e -> handle_extension e
+
+and add_class_declaration bv decl =
+  add_class_expr bv decl.pci_expr
diff --git a/parsing/depend.mli b/parsing/depend.mli
new file mode 100644
index 00000000..e34abbe7
--- /dev/null
+++ b/parsing/depend.mli
@@ -0,0 +1,38 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Module dependencies. *)
+
+module StringSet : Set.S with type elt = string
+module StringMap : Map.S with type key = string
+
+type map_tree = Node of StringSet.t * bound_map
+and  bound_map = map_tree StringMap.t
+val make_leaf : string -> map_tree
+val make_node : bound_map -> map_tree
+val weaken_map : StringSet.t -> map_tree -> map_tree
+
+val free_structure_names : StringSet.t ref
+
+val open_module : bound_map -> Longident.t -> bound_map
+
+val add_use_file : bound_map -> Parsetree.toplevel_phrase list -> unit
+
+val add_signature : bound_map -> Parsetree.signature -> unit
+
+val add_implementation : bound_map -> Parsetree.structure -> unit
+
+val add_implementation_binding : bound_map -> Parsetree.structure -> bound_map
+val add_signature_binding : bound_map -> Parsetree.signature -> bound_map
diff --git a/parsing/docstrings.ml b/parsing/docstrings.ml
index 724a499d..5524aea2 100644
--- a/parsing/docstrings.ml
+++ b/parsing/docstrings.ml
@@ -59,7 +59,7 @@ let warn_bad_docstrings () =
       (List.rev !docstrings)
 end
 
-(* Docstring constructors and descturctors *)
+(* Docstring constructors and destructors *)
 
 let docstring body loc =
   let ds =
@@ -68,9 +68,11 @@ let docstring body loc =
       ds_attached = Unattached;
       ds_associated = Zero; }
   in
-  docstrings := ds :: !docstrings;
   ds
 
+let register ds =
+  docstrings := ds :: !docstrings
+
 let docstring_body ds = ds.ds_body
 
 let docstring_loc ds = ds.ds_loc
@@ -100,17 +102,17 @@ let docs_attr ds =
 let add_docs_attrs docs attrs =
   let attrs =
     match docs.docs_pre with
-    | None -> attrs
+    | None | Some { ds_body=""; _ } -> attrs
     | Some ds -> docs_attr ds :: attrs
   in
   let attrs =
     match docs.docs_post with
-    | None -> attrs
+    | None | Some { ds_body=""; _ } -> attrs
     | Some ds -> attrs @ [docs_attr ds]
   in
   attrs
 
-(* Docstrings attached to consturctors or fields *)
+(* Docstrings attached to constructors or fields *)
 
 type info = docstring option
 
@@ -120,7 +122,7 @@ let info_attr = docs_attr
 
 let add_info_attrs info attrs =
   match info with
-  | None -> attrs
+  | None | Some {ds_body=""; _} -> attrs
   | Some ds -> attrs @ [info_attr ds]
 
 (* Docstrings not attached to a specifc item *)
@@ -145,14 +147,15 @@ let text_attr ds =
     (text_loc, PStr [item])
 
 let add_text_attrs dsl attrs =
-  (List.map text_attr dsl) @ attrs
+  let fdsl = List.filter (function {ds_body=""} -> false| _ ->true) dsl in
+  (List.map text_attr fdsl) @ attrs
 
 (* Find the first non-info docstring in a list, attach it and return it *)
 let get_docstring ~info dsl =
   let rec loop = function
     | [] -> None
     | {ds_attached = Info; _} :: rest -> loop rest
-    | ds :: rest ->
+    | ds :: _ ->
         ds.ds_attached <- if info then Info else Docs;
         Some ds
   in
diff --git a/parsing/docstrings.mli b/parsing/docstrings.mli
index 01103b7e..500ecbf0 100644
--- a/parsing/docstrings.mli
+++ b/parsing/docstrings.mli
@@ -13,6 +13,8 @@
 (*                                                                        *)
 (**************************************************************************)
 
+(** Documentation comments *)
+
 (** (Re)Initialise all docstring state *)
 val init : unit -> unit
 
@@ -27,6 +29,9 @@ type docstring
 (** Create a docstring *)
 val docstring : string -> Location.t -> docstring
 
+(** Register a docstring *)
+val register : docstring -> unit
+
 (** Get the text of a docstring *)
 val docstring_body : docstring -> string
 
diff --git a/parsing/lexer.mli b/parsing/lexer.mli
index 846745da..63617b48 100644
--- a/parsing/lexer.mli
+++ b/parsing/lexer.mli
@@ -17,7 +17,7 @@
 
 val init : unit -> unit
 val token: Lexing.lexbuf -> Parser.token
-val skip_sharp_bang: Lexing.lexbuf -> unit
+val skip_hash_bang: Lexing.lexbuf -> unit
 
 type error =
   | Illegal_character of char
@@ -27,6 +27,7 @@ type error =
   | Unterminated_string_in_comment of Location.t * Location.t
   | Keyword_as_label of string
   | Invalid_literal of string
+  | Invalid_directive of string * string option
 ;;
 
 exception Error of error * Location.t
diff --git a/parsing/lexer.mll b/parsing/lexer.mll
index 0100867e..a485f3ed 100644
--- a/parsing/lexer.mll
+++ b/parsing/lexer.mll
@@ -28,6 +28,7 @@ type error =
   | Unterminated_string_in_comment of Location.t * Location.t
   | Keyword_as_label of string
   | Invalid_literal of string
+  | Invalid_directive of string * string option
 ;;
 
 exception Error of error * Location.t;;
@@ -260,6 +261,12 @@ let report_error ppf = function
       fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd
   | Invalid_literal s ->
       fprintf ppf "Invalid literal %s" s
+  | Invalid_directive (dir, explanation) ->
+      fprintf ppf "Invalid lexer directive %S" dir;
+      begin match explanation with
+        | None -> ()
+        | Some expl -> fprintf ppf ": %s" expl
+      end
 
 let () =
   Location.register_error_of_exn
@@ -398,7 +405,7 @@ rule token = parse
         else
           COMMENT ("*" ^ s, loc)
       }
-  | "(**" ('*'+) as stars
+  | "(**" (('*'+) as stars)
       { let s, loc =
           with_comment_buffer
             (fun lexbuf ->
@@ -412,8 +419,12 @@ rule token = parse
           Location.prerr_warning (Location.curr lexbuf) Warnings.Comment_start;
         let s, loc = with_comment_buffer comment lexbuf in
         COMMENT (s, loc) }
-  | "(*" ('*'*) as stars "*)"
-      { COMMENT (stars, Location.curr lexbuf) }
+  | "(*" (('*'*) as stars) "*)"
+      { if !handle_docstrings && stars="" then
+         (* (**) is an empty docstring *)
+          DOCSTRING(Docstrings.docstring "" (Location.curr lexbuf))
+        else
+          COMMENT (stars, Location.curr lexbuf) }
   | "*)"
       { let loc = Location.curr lexbuf in
         Location.prerr_warning loc Warnings.Comment_not_end;
@@ -422,13 +433,25 @@ rule token = parse
         lexbuf.lex_curr_p <- { curpos with pos_cnum = curpos.pos_cnum - 1 };
         STAR
       }
-  | "#" [' ' '\t']* (['0'-'9']+ as num) [' ' '\t']*
-        ("\"" ([^ '\010' '\013' '\"' ] * as name) "\"")?
+  | ("#" [' ' '\t']* (['0'-'9']+ as num) [' ' '\t']*
+        ("\"" ([^ '\010' '\013' '\"' ] * as name) "\"")?) as directive
         [^ '\010' '\013'] * newline
-      { update_loc lexbuf name (int_of_string num) true 0;
-        token lexbuf
+      {
+        match int_of_string num with
+        | exception _ ->
+            (* PR#7165 *)
+            let loc = Location.curr lexbuf in
+            let explanation = "line number out of range" in
+            let error = Invalid_directive (directive, Some explanation) in
+            raise (Error (error, loc))
+        | line_num ->
+           (* Documentation says that the line number should be
+              positive, but we have never guarded against this and it
+              might have useful hackish uses. *)
+            update_loc lexbuf name line_num true 0;
+            token lexbuf
       }
-  | "#"  { SHARP }
+  | "#"  { HASH }
   | "&"  { AMPERSAND }
   | "&&" { AMPERAMPER }
   | "`"  { BACKQUOTE }
@@ -492,7 +515,7 @@ rule token = parse
   | ['*' '/' '%'] symbolchar *
             { INFIXOP3(Lexing.lexeme lexbuf) }
   | '#' (symbolchar | '#') +
-            { SHARPOP(Lexing.lexeme lexbuf) }
+            { HASHOP(Lexing.lexeme lexbuf) }
   | eof { EOF }
   | _
       { raise (Error(Illegal_character (Lexing.lexeme_char lexbuf 0),
@@ -652,7 +675,7 @@ and quoted_string delim = parse
       { store_string_char(Lexing.lexeme_char lexbuf 0);
         quoted_string delim lexbuf }
 
-and skip_sharp_bang = parse
+and skip_hash_bang = parse
   | "#!" [^ '\n']* '\n' [^ '\n']* "\n!#\n"
        { update_loc lexbuf None 3 false 0 }
   | "#!" [^ '\n']* '\n'
@@ -731,15 +754,22 @@ and skip_sharp_bang = parse
           in
           loop lines' docs lexbuf
       | DOCSTRING doc ->
+          Docstrings.register doc;
           add_docstring_comment doc;
           let docs' =
-            match docs, lines with
-            | Initial, (NoLine | NewLine) -> After [doc]
-            | Initial, BlankLine -> Before([], [], [doc])
-            | After a, (NoLine | NewLine) -> After (doc :: a)
-            | After a, BlankLine -> Before (a, [], [doc])
-            | Before(a, f, b), (NoLine | NewLine) -> Before(a, f, doc :: b)
-            | Before(a, f, b), BlankLine -> Before(a, b @ f, [doc])
+            if Docstrings.docstring_body doc = "/*" then
+              match docs with
+              | Initial -> Before([], [doc], [])
+              | After a -> Before (a, [doc], [])
+              | Before(a, f, b) -> Before(a, doc :: b @ f, [])
+            else
+              match docs, lines with
+              | Initial, (NoLine | NewLine) -> After [doc]
+              | Initial, BlankLine -> Before([], [], [doc])
+              | After a, (NoLine | NewLine) -> After (doc :: a)
+              | After a, BlankLine -> Before (a, [], [doc])
+              | Before(a, f, b), (NoLine | NewLine) -> Before(a, f, doc :: b)
+              | Before(a, f, b), BlankLine -> Before(a, b @ f, [doc])
           in
           loop NoLine docs' lexbuf
       | tok ->
diff --git a/parsing/location.ml b/parsing/location.ml
index 96d0c0cf..abe47ef0 100644
--- a/parsing/location.ml
+++ b/parsing/location.ml
@@ -359,14 +359,14 @@ let pp_ksprintf ?before k fmt =
       k msg)
     ppf fmt
 
-let errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") fmt =
-  pp_ksprintf
-    (fun msg -> {loc; msg; sub; if_highlight})
-    fmt
+(* Shift the formatter's offset by the length of the error prefix, which
+   is always added by the compiler after the message has been formatted *)
+let print_phanton_error_prefix ppf =
+  Format.pp_print_as ppf (String.length error_prefix + 2 (* ": " *)) ""
 
-let errorf_prefixed ?(loc=none) ?(sub=[]) ?(if_highlight="") fmt =
+let errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") fmt =
   pp_ksprintf
-    ~before:(fun ppf -> fprintf ppf "%a " print_error_prefix ())
+    ~before:print_phanton_error_prefix
     (fun msg -> {loc; msg; sub; if_highlight})
     fmt
 
@@ -390,7 +390,7 @@ let error_of_exn exn =
 let rec default_error_reporter ppf ({loc; msg; sub; if_highlight} as err) =
   let highlighted =
     if if_highlight <> "" && loc.loc_start.pos_fname = "//toplevel//" then
-      let rec collect_locs locs {loc; sub; if_highlight; _} =
+      let rec collect_locs locs {loc; sub; _} =
         List.fold_left collect_locs (loc :: locs) sub
       in
       let locs = collect_locs [] err in
@@ -401,8 +401,7 @@ let rec default_error_reporter ppf ({loc; msg; sub; if_highlight} as err) =
   if highlighted then
     Format.pp_print_string ppf if_highlight
   else begin
-    print ppf loc;
-    Format.pp_print_string ppf msg;
+    fprintf ppf "%a%a %s" print loc print_error_prefix () msg;
     List.iter (Format.fprintf ppf "@\n@[<2>%a@]" default_error_reporter) sub
   end
 
@@ -413,7 +412,7 @@ let report_error ppf err =
 ;;
 
 let error_of_printer loc print x =
-  errorf_prefixed ~loc "%a@?" print x
+  errorf ~loc "%a@?" print x
 
 let error_of_printer_file print x =
   error_of_printer (in_file !input_name) print x
@@ -422,16 +421,25 @@ let () =
   register_error_of_exn
     (function
       | Sys_error msg ->
-          Some (errorf_prefixed ~loc:(in_file !input_name)
+          Some (errorf ~loc:(in_file !input_name)
                 "I/O error: %s" msg)
       | Warnings.Errors n ->
           Some
-            (errorf_prefixed ~loc:(in_file !input_name)
+            (errorf ~loc:(in_file !input_name)
              "Some fatal warnings were triggered (%d occurrences)" n)
-      | _ ->
-          None
-    )
 
+      | Misc.HookExnWrapper {error = e; hook_name;
+                             hook_info={Misc.sourcefile}} ->
+          let sub = match error_of_exn e with
+            | None -> error (Printexc.to_string e)
+            | Some err -> err
+          in
+          Some
+            (errorf ~loc:(in_file sourcefile)
+               "In hook %S:" hook_name
+               ~sub:[sub])
+      | _ -> None
+    )
 
 external reraise : exn -> 'a = "%reraise"
 
@@ -456,4 +464,6 @@ let () =
     )
 
 let raise_errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") =
-  pp_ksprintf (fun msg -> raise (Error ({loc; msg; sub; if_highlight})))
+  pp_ksprintf
+    ~before:print_phanton_error_prefix
+    (fun msg -> raise (Error ({loc; msg; sub; if_highlight})))
diff --git a/parsing/location.mli b/parsing/location.mli
index 866914ad..4a7ac959 100644
--- a/parsing/location.mli
+++ b/parsing/location.mli
@@ -13,7 +13,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(* Source code locations (ranges of positions), used in parsetree. *)
+(** Source code locations (ranges of positions), used in parsetree. *)
 
 open Format
 
@@ -23,7 +23,7 @@ type t = {
   loc_ghost: bool;
 }
 
-(* Note on the use of Lexing.position in this module.
+(** Note on the use of Lexing.position in this module.
    If [pos_fname = ""], then use [!input_name] instead.
    If [pos_lnum = -1], then [pos_bol = 0]. Use [pos_cnum] and
      re-parse the file to get the line and character numbers.
@@ -112,11 +112,6 @@ val error: ?loc:t -> ?sub:error list -> ?if_highlight:string -> string -> error
 val errorf: ?loc:t -> ?sub:error list -> ?if_highlight:string
             -> ('a, Format.formatter, unit, error) format4 -> 'a
 
-val errorf_prefixed : ?loc:t -> ?sub:error list -> ?if_highlight:string
-                    -> ('a, Format.formatter, unit, error) format4 -> 'a
-  (* same as {!errorf}, but prints the error prefix "Error:" before yielding
-   * to the format string *)
-
 val raise_errorf: ?loc:t -> ?sub:error list -> ?if_highlight:string
             -> ('a, Format.formatter, unit, 'b) format4 -> 'a
 
diff --git a/parsing/longident.mli b/parsing/longident.mli
index 6f364a0e..c7e7f3d2 100644
--- a/parsing/longident.mli
+++ b/parsing/longident.mli
@@ -13,7 +13,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(* Long identifiers, used in parsetree. *)
+(** Long identifiers, used in parsetree. *)
 
 type t =
     Lident of string
diff --git a/parsing/parse.mli b/parsing/parse.mli
index 78223a3b..8e6eb454 100644
--- a/parsing/parse.mli
+++ b/parsing/parse.mli
@@ -13,7 +13,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(* Entry points in the parser *)
+(** Entry points in the parser *)
 
 val implementation : Lexing.lexbuf -> Parsetree.structure
 val interface : Lexing.lexbuf -> Parsetree.signature
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 684565fa..1b642b2a 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -561,8 +561,8 @@ let package_type_of_module_type pmty =
 %token RPAREN
 %token SEMI
 %token SEMISEMI
-%token SHARP
-%token  SHARPOP
+%token HASH
+%token  HASHOP
 %token SIG
 %token STAR
 %token  STRING
@@ -639,9 +639,9 @@ The precedences must be listed from low to high.
 %nonassoc prec_unary_minus prec_unary_plus /* unary - */
 %nonassoc prec_constant_constructor     /* cf. simple_expr (C versus C x) */
 %nonassoc prec_constr_appl              /* above AS BAR COLONCOLON COMMA */
-%nonassoc below_SHARP
-%nonassoc SHARP                         /* simple_expr/toplevel_directive */
-%left     SHARPOP
+%nonassoc below_HASH
+%nonassoc HASH                         /* simple_expr/toplevel_directive */
+%left     HASHOP
 %nonassoc below_DOT
 %nonassoc DOT
 /* Finally, the first tokens of simple_expr are above everything else. */
@@ -1268,7 +1268,7 @@ class_description:
     CLASS ext_attributes virtual_flag class_type_parameters LIDENT COLON
     class_type post_item_attributes
       { let (ext, attrs) = $2 in
-        Ci.mk (mkrhs $5 5) $7 ~virt:$3 ~params:$4 ~attrs:(attrs@$8)
+        Ci.mk (mkrhs $5 5) $7 ~virt:$3 ~params:$4 ~attrs:(attrs @ $8)
             ~loc:(symbol_rloc ()) ~docs:(symbol_docs ())
       , ext }
 ;
@@ -1307,6 +1307,10 @@ seq_expr:
   | expr        %prec below_SEMI  { $1 }
   | expr SEMI                     { reloc_exp $1 }
   | expr SEMI seq_expr            { mkexp(Pexp_sequence($1, $3)) }
+  | expr SEMI PERCENT attr_id seq_expr
+      { let seq = mkexp(Pexp_sequence ($1, $5)) in
+        let payload = PStr [mkstrexp seq []] in
+        mkexp (Pexp_extension ($4, payload)) }
 ;
 labeled_simple_pattern:
     QUESTION LPAREN label_let_pattern opt_default RPAREN
@@ -1350,7 +1354,7 @@ let_pattern:
       { mkpat(Ppat_constraint($1, $3)) }
 ;
 expr:
-    simple_expr %prec below_SHARP
+    simple_expr %prec below_HASH
       { $1 }
   | simple_expr simple_labeled_expr_list
       { mkexp(Pexp_apply($1, List.rev $2)) }
@@ -1358,6 +1362,8 @@ expr:
       { expr_of_let_bindings $1 $3 }
   | LET MODULE ext_attributes UIDENT module_binding_body IN seq_expr
       { mkexp_attrs (Pexp_letmodule(mkrhs $4 4, $5, $7)) $3 }
+  | LET EXCEPTION ext_attributes let_exception_declaration IN seq_expr
+      { mkexp_attrs (Pexp_letexception($4, $6)) $3 }
   | LET OPEN override_flag ext_attributes mod_longident IN seq_expr
       { mkexp_attrs (Pexp_open($3, mkrhs $5 5, $7)) $4 }
   | FUNCTION ext_attributes opt_bar match_cases
@@ -1375,9 +1381,9 @@ expr:
       { syntax_error() }
   | expr_comma_list %prec below_COMMA
       { mkexp(Pexp_tuple(List.rev $1)) }
-  | constr_longident simple_expr %prec below_SHARP
+  | constr_longident simple_expr %prec below_HASH
       { mkexp(Pexp_construct(mkrhs $1 1, Some $2)) }
-  | name_tag simple_expr %prec below_SHARP
+  | name_tag simple_expr %prec below_HASH
       { mkexp(Pexp_variant($1, Some $2)) }
   | IF ext_attributes seq_expr THEN expr ELSE expr
       { mkexp_attrs(Pexp_ifthenelse($3, $5, Some $7)) $2 }
@@ -1419,7 +1425,7 @@ expr:
   | expr EQUAL expr
       { mkinfix $1 "=" $3 }
   | expr LESS expr
-      { mkinfix $1 "<" $3 }
+    { mkinfix $1 "<" $3 }
   | expr GREATER expr
       { mkinfix $1 ">" $3 }
   | expr OR expr
@@ -1448,9 +1454,9 @@ expr:
       { bigarray_set $1 $4 $7 }
   | label LESSMINUS expr
       { mkexp(Pexp_setinstvar(mkrhs $1 1, $3)) }
-  | ASSERT ext_attributes simple_expr %prec below_SHARP
+  | ASSERT ext_attributes simple_expr %prec below_HASH
       { mkexp_attrs (Pexp_assert $3) $2 }
-  | LAZY ext_attributes simple_expr %prec below_SHARP
+  | LAZY ext_attributes simple_expr %prec below_HASH
       { mkexp_attrs (Pexp_lazy $3) $2 }
   | OBJECT ext_attributes class_structure END
       { mkexp_attrs (Pexp_object $3) $2 }
@@ -1558,9 +1564,9 @@ simple_expr:
       { mkexp(Pexp_open(Fresh, mkrhs $1 1, mkexp (Pexp_override [])))}
   | mod_longident DOT LBRACELESS field_expr_list error
       { unclosed "{<" 3 ">}" 5 }
-  | simple_expr SHARP label
+  | simple_expr HASH label
       { mkexp(Pexp_send($1, $3)) }
-  | simple_expr SHARPOP simple_expr
+  | simple_expr HASHOP simple_expr
       { mkinfix $1 $2 $3 }
   | LPAREN MODULE ext_attributes module_expr RPAREN
       { mkexp_attrs (Pexp_pack $4) $3 }
@@ -1588,19 +1594,19 @@ simple_labeled_expr_list:
       { $2 :: $1 }
 ;
 labeled_simple_expr:
-    simple_expr %prec below_SHARP
+    simple_expr %prec below_HASH
       { (Nolabel, $1) }
   | label_expr
       { $1 }
 ;
 label_expr:
-    LABEL simple_expr %prec below_SHARP
+    LABEL simple_expr %prec below_HASH
       { (Labelled $1, $2) }
   | TILDE label_ident
       { (Labelled (fst $2), snd $2) }
   | QUESTION label_ident
       { (Optional (fst $2), snd $2) }
-  | OPTLABEL simple_expr %prec below_SHARP
+  | OPTLABEL simple_expr %prec below_HASH
       { (Optional $1, $2) }
 ;
 label_ident:
@@ -1620,7 +1626,7 @@ let_binding_body:
   | val_ident COLON TYPE lident_list DOT core_type EQUAL seq_expr
       { let exp, poly = wrap_type_annotation $4 $6 $8 in
         (ghpat(Ppat_constraint(mkpatvar $1 1, poly)), exp) }
-  | pattern EQUAL seq_expr
+  | pattern_no_exn EQUAL seq_expr
       { ($1, $3) }
   | simple_pattern_not_ident COLON core_type EQUAL seq_expr
       { (ghpat(Ppat_constraint($1, $3)), $5) }
@@ -1726,36 +1732,58 @@ opt_type_constraint:
 /* Patterns */
 
 pattern:
-    simple_pattern
-      { $1 }
   | pattern AS val_ident
       { mkpat(Ppat_alias($1, mkrhs $3 3)) }
   | pattern AS error
       { expecting 3 "identifier" }
   | pattern_comma_list  %prec below_COMMA
       { mkpat(Ppat_tuple(List.rev $1)) }
-  | constr_longident pattern %prec prec_constr_appl
-      { mkpat(Ppat_construct(mkrhs $1 1, Some $2)) }
-  | name_tag pattern %prec prec_constr_appl
-      { mkpat(Ppat_variant($1, Some $2)) }
   | pattern COLONCOLON pattern
       { mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[$1;$3])) (symbol_rloc()) }
   | pattern COLONCOLON error
       { expecting 3 "pattern" }
-  | LPAREN COLONCOLON RPAREN LPAREN pattern COMMA pattern RPAREN
-      { mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[$5;$7])) (symbol_rloc()) }
-  | LPAREN COLONCOLON RPAREN LPAREN pattern COMMA pattern error
-      { unclosed "(" 4 ")" 8 }
   | pattern BAR pattern
       { mkpat(Ppat_or($1, $3)) }
   | pattern BAR error
       { expecting 3 "pattern" }
-  | LAZY ext_attributes simple_pattern
-      { mkpat_attrs (Ppat_lazy $3) $2}
   | EXCEPTION ext_attributes pattern %prec prec_constr_appl
       { mkpat_attrs (Ppat_exception $3) $2}
   | pattern attribute
       { Pat.attr $1 $2 }
+  | pattern_gen { $1 }
+;
+pattern_no_exn:
+  | pattern_no_exn AS val_ident
+      { mkpat(Ppat_alias($1, mkrhs $3 3)) }
+  | pattern_no_exn AS error
+      { expecting 3 "identifier" }
+  | pattern_no_exn_comma_list  %prec below_COMMA
+      { mkpat(Ppat_tuple(List.rev $1)) }
+  | pattern_no_exn COLONCOLON pattern
+      { mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[$1;$3])) (symbol_rloc()) }
+  | pattern_no_exn COLONCOLON error
+      { expecting 3 "pattern" }
+  | pattern_no_exn BAR pattern
+      { mkpat(Ppat_or($1, $3)) }
+  | pattern_no_exn BAR error
+      { expecting 3 "pattern" }
+  | pattern_no_exn attribute
+      { Pat.attr $1 $2 }
+  | pattern_gen { $1 }
+;
+pattern_gen:
+    simple_pattern
+      { $1 }
+  | constr_longident pattern %prec prec_constr_appl
+      { mkpat(Ppat_construct(mkrhs $1 1, Some $2)) }
+  | name_tag pattern %prec prec_constr_appl
+      { mkpat(Ppat_variant($1, Some $2)) }
+  | LPAREN COLONCOLON RPAREN LPAREN pattern COMMA pattern RPAREN
+      { mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[$5;$7])) (symbol_rloc()) }
+  | LPAREN COLONCOLON RPAREN LPAREN pattern COMMA pattern error
+      { unclosed "(" 4 ")" 8 }
+  | LAZY ext_attributes simple_pattern
+      { mkpat_attrs (Ppat_lazy $3) $2}
 ;
 simple_pattern:
     val_ident %prec below_EQUAL
@@ -1773,22 +1801,24 @@ simple_pattern_not_ident:
       { mkpat(Ppat_construct(mkrhs $1 1, None)) }
   | name_tag
       { mkpat(Ppat_variant($1, None)) }
-  | SHARP type_longident
+  | HASH type_longident
       { mkpat(Ppat_type (mkrhs $2 2)) }
-  | LBRACE lbl_pattern_list RBRACE
-      { let (fields, closed) = $2 in mkpat(Ppat_record(fields, closed)) }
-  | LBRACE lbl_pattern_list error
-      { unclosed "{" 1 "}" 3 }
-  | LBRACKET pattern_semi_list opt_semi RBRACKET
-      { reloc_pat (mktailpat (rhs_loc 4) (List.rev $2)) }
-  | LBRACKET pattern_semi_list opt_semi error
-      { unclosed "[" 1 "]" 4 }
-  | LBRACKETBAR pattern_semi_list opt_semi BARRBRACKET
-      { mkpat(Ppat_array(List.rev $2)) }
-  | LBRACKETBAR BARRBRACKET
-      { mkpat(Ppat_array []) }
-  | LBRACKETBAR pattern_semi_list opt_semi error
-      { unclosed "[|" 1 "|]" 4 }
+  | simple_delimited_pattern
+      { $1 }
+  | mod_longident DOT simple_delimited_pattern
+      { mkpat @@ Ppat_open(mkrhs $1 1, $3) }
+  | mod_longident DOT LBRACKET RBRACKET
+    { mkpat @@ Ppat_open(mkrhs $1 1, mkpat @@
+               Ppat_construct ( mkrhs (Lident "[]") 4, None)) }
+  | mod_longident DOT LPAREN RPAREN
+      { mkpat @@ Ppat_open( mkrhs $1 1, mkpat @@
+                 Ppat_construct ( mkrhs (Lident "()") 4, None) ) }
+  | mod_longident DOT LPAREN pattern RPAREN
+      { mkpat @@ Ppat_open (mkrhs $1 1, $4)}
+  | mod_longident DOT LPAREN pattern error
+      {unclosed "(" 3 ")" 5  }
+  | mod_longident DOT LPAREN error
+      { expecting 4 "pattern" }
   | LPAREN pattern RPAREN
       { reloc_pat $2 }
   | LPAREN pattern error
@@ -1812,11 +1842,32 @@ simple_pattern_not_ident:
       { mkpat(Ppat_extension $1) }
 ;
 
+simple_delimited_pattern:
+  | LBRACE lbl_pattern_list RBRACE
+    { let (fields, closed) = $2 in mkpat(Ppat_record(fields, closed)) }
+  | LBRACE lbl_pattern_list error
+    { unclosed "{" 1 "}" 3 }
+  | LBRACKET pattern_semi_list opt_semi RBRACKET
+    { reloc_pat (mktailpat (rhs_loc 4) (List.rev $2)) }
+  | LBRACKET pattern_semi_list opt_semi error
+    { unclosed "[" 1 "]" 4 }
+  | LBRACKETBAR pattern_semi_list opt_semi BARRBRACKET
+    { mkpat(Ppat_array(List.rev $2)) }
+  | LBRACKETBAR BARRBRACKET
+    { mkpat(Ppat_array []) }
+  | LBRACKETBAR pattern_semi_list opt_semi error
+    { unclosed "[|" 1 "|]" 4 }
+
 pattern_comma_list:
     pattern_comma_list COMMA pattern            { $3 :: $1 }
   | pattern COMMA pattern                       { [$3; $1] }
   | pattern COMMA error                         { expecting 3 "pattern" }
 ;
+pattern_no_exn_comma_list:
+    pattern_no_exn_comma_list COMMA pattern     { $3 :: $1 }
+  | pattern_no_exn COMMA pattern                { [$3; $1] }
+  | pattern_no_exn COMMA error                  { expecting 3 "pattern" }
+;
 pattern_semi_list:
     pattern                                     { [$1] }
   | pattern_semi_list SEMI pattern              { $3 :: $1 }
@@ -1996,6 +2047,11 @@ sig_exception_declaration:
             ~loc:(symbol_rloc()) ~docs:(symbol_docs ())
         , ext }
 ;
+let_exception_declaration:
+    constr_ident generalized_constructor_arguments attributes
+      { let args, res = $2 in
+        Te.decl (mkrhs $1 1) ~args ?res ~attrs:$3 ~loc:(symbol_rloc()) }
+;
 generalized_constructor_arguments:
     /*empty*/                     { (Pcstr_tuple [],None) }
   | OF constructor_arguments      { ($2,None) }
@@ -2180,9 +2236,9 @@ core_type2:
 ;
 
 simple_core_type:
-    simple_core_type2  %prec below_SHARP
+    simple_core_type2  %prec below_HASH
       { $1 }
-  | LPAREN core_type_comma_list RPAREN %prec below_SHARP
+  | LPAREN core_type_comma_list RPAREN %prec below_HASH
       { match $2 with [sty] -> sty | _ -> raise Parse_error }
 ;
 
@@ -2201,11 +2257,11 @@ simple_core_type2:
       { let (f, c) = $2 in mktyp(Ptyp_object (f, c)) }
   | LESS GREATER
       { mktyp(Ptyp_object ([], Closed)) }
-  | SHARP class_longident
+  | HASH class_longident
       { mktyp(Ptyp_class(mkrhs $2 2, [])) }
-  | simple_core_type2 SHARP class_longident
+  | simple_core_type2 HASH class_longident
       { mktyp(Ptyp_class(mkrhs $3 3, [$1])) }
-  | LPAREN core_type_comma_list RPAREN SHARP class_longident
+  | LPAREN core_type_comma_list RPAREN HASH class_longident
       { mktyp(Ptyp_class(mkrhs $5 5, List.rev $2)) }
   | LBRACKET tag_field RBRACKET
       { mktyp(Ptyp_variant([$2], Closed, None)) }
@@ -2333,7 +2389,7 @@ operator:
   | INFIXOP2                                    { $1 }
   | INFIXOP3                                    { $1 }
   | INFIXOP4                                    { $1 }
-  | SHARPOP                                     { $1 }
+  | HASHOP                                     { $1 }
   | BANG                                        { "!" }
   | PLUS                                        { "+" }
   | PLUSDOT                                     { "+." }
@@ -2405,14 +2461,14 @@ class_longident:
 /* Toplevel directives */
 
 toplevel_directive:
-    SHARP ident                 { Ptop_dir($2, Pdir_none) }
-  | SHARP ident STRING          { Ptop_dir($2, Pdir_string (fst $3)) }
-  | SHARP ident INT             { let (n, m) = $3 in
+    HASH ident                 { Ptop_dir($2, Pdir_none) }
+  | HASH ident STRING          { Ptop_dir($2, Pdir_string (fst $3)) }
+  | HASH ident INT             { let (n, m) = $3 in
                                   Ptop_dir($2, Pdir_int (n ,m)) }
-  | SHARP ident val_longident   { Ptop_dir($2, Pdir_ident $3) }
-  | SHARP ident mod_longident   { Ptop_dir($2, Pdir_ident $3) }
-  | SHARP ident FALSE           { Ptop_dir($2, Pdir_bool false) }
-  | SHARP ident TRUE            { Ptop_dir($2, Pdir_bool true) }
+  | HASH ident val_longident   { Ptop_dir($2, Pdir_ident $3) }
+  | HASH ident mod_longident   { Ptop_dir($2, Pdir_ident $3) }
+  | HASH ident FALSE           { Ptop_dir($2, Pdir_bool false) }
+  | HASH ident TRUE            { Ptop_dir($2, Pdir_bool true) }
 ;
 
 /* Miscellaneous */
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index d3796f78..d61b3392 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -220,6 +220,7 @@ and pattern_desc =
         (* exception P *)
   | Ppat_extension of extension
         (* [%id] *)
+  | Ppat_open of Longident.t loc * pattern
 
 (* Value expressions *)
 
@@ -318,6 +319,8 @@ and expression_desc =
         (* {< x1 = E1; ...; Xn = En >} *)
   | Pexp_letmodule of string loc * module_expr * expression
         (* let module M = ME in E *)
+  | Pexp_letexception of extension_constructor * expression
+        (* let exception C in E *)
   | Pexp_assert of expression
         (* assert E
            Note: "assert false" is treated in a special way by the
diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml
index 90bfaa51..f9e51522 100644
--- a/parsing/pprintast.ml
+++ b/parsing/pprintast.ml
@@ -30,7 +30,7 @@ open Parsetree
 let prefix_symbols  = [ '!'; '?'; '~' ] ;;
 let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/';
                       '$'; '%' ]
-
+(* type fixity = Infix| Prefix  *)
 let special_infix_strings =
   ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!=" ]
 
@@ -122,176 +122,185 @@ let is_simple_construct :construct -> bool = function
 
 let pp = fprintf
 
-class printer  ()= object(self:'self)
-  val pipe = false
-  val semi = false
-  val ifthenelse = false
-  method under_pipe = {}
-  method under_semi = {}
-  method under_ifthenelse = {}
-  method reset_semi = {}
-  method reset_ifthenelse = {}
-  method reset_pipe = {}
-  method reset = {}
-  method list : 'a . ?sep:space_formatter -> ?first:space_formatter ->
-    ?last:space_formatter -> (Format.formatter -> 'a -> unit) ->
-    Format.formatter -> 'a list -> unit
-        = fun  ?sep ?first  ?last fu f xs ->
-          let first = match first with Some x -> x |None -> ("" : _ format6)
-          and last = match last with Some x -> x |None -> ("" : _ format6)
-          and sep = match sep with Some x -> x |None -> ("@ " : _ format6) in
-          let aux f = function
-            | [] -> ()
+type ctxt = {
+  pipe : bool;
+  semi : bool;
+  ifthenelse : bool;
+}
+
+let reset_ctxt = { pipe=false; semi=false; ifthenelse=false }
+let under_pipe ctxt = { ctxt with pipe=true }
+let under_semi ctxt = { ctxt with semi=true }
+let under_ifthenelse ctxt = { ctxt with ifthenelse=true }
+(*
+let reset_semi ctxt = { ctxt with semi=false }
+let reset_ifthenelse ctxt = { ctxt with ifthenelse=false }
+let reset_pipe ctxt = { ctxt with pipe=false }
+*)
+
+let list : 'a . ?sep:space_formatter -> ?first:space_formatter ->
+  ?last:space_formatter -> (Format.formatter -> 'a -> unit) ->
+  Format.formatter -> 'a list -> unit
+  = fun ?sep ?first ?last fu f xs ->
+    let first = match first with Some x -> x |None -> ("": _ format6)
+    and last = match last with Some x -> x |None -> ("": _ format6)
+    and sep = match sep with Some x -> x |None -> ("@ ": _ format6) in
+    let aux f = function
+      | [] -> ()
+      | [x] -> fu f x
+      | xs ->
+          let rec loop  f = function
             | [x] -> fu f x
-            | xs ->
-                let rec loop  f = function
-                  | [x] -> fu f x
-                  | x::xs ->  fu f x; pp f sep; loop f xs;
-                  | _ -> assert false in begin
-                      pp f first; loop f xs; pp f last;
-                  end in
-          aux f xs
-  method option : 'a. ?first:space_formatter -> ?last:space_formatter ->
-    (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit =
-      fun  ?first  ?last fu f a ->
-        let first = match first with Some x -> x | None -> ("" : _ format6)
-        and last = match last with Some x -> x | None -> ("" : _ format6) in
-        match a with
-        | None -> ()
-        | Some x -> pp f first; fu f x; pp f last;
-  method paren: 'a . ?first:space_formatter -> ?last:space_formatter ->
-    bool -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit =
-    fun  ?(first=("" : _ format6)) ?(last=("" : _ format6)) b fu f x ->
-      if b then (pp f "("; pp f first; fu f x; pp f last; pp f ")")
-      else fu f x
-
-
-  method longident f = function
-    | Lident s -> protect_ident f s
-    | Ldot(y,s) -> protect_longident f self#longident y s
-    | Lapply (y,s) ->
-        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_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
-    | Immutable -> ()
-    | Mutable -> pp f "mutable@;"
-  method virtual_flag f  = function
-    | Concrete -> ()
-    | Virtual -> pp f "virtual@;"
-
-  (* trailing space added *)
-  method rec_flag f rf =
-    match rf with
-    | Nonrecursive -> ()
-    | Recursive -> pp f "rec "
-  method nonrec_flag f rf =
-    match rf with
-    | Nonrecursive -> pp f "nonrec "
-    | Recursive -> ()
-  method direction_flag f = function
-    | Upto -> pp f "to@ "
-    | Downto -> pp f "downto@ "
-  method private_flag f = function
-    | Public -> ()
-    | Private -> pp f "private@ "
-
-  method constant_string f s = pp f "%S" s
-  method tyvar f str = pp f "'%s" str
-  method string_quot f x = pp f "`%s" x
-
-          (* c ['a,'b] *)
-  method class_params_def f =  function
-    | [] -> ()
-    | l ->
-        pp f "[%a] " (* space *)
-          (self#list self#type_param ~sep:",") l
-
-  method type_with_label f (label,({ptyp_desc;_}as c) ) =
-    match label with
-    | Nolabel ->  self#core_type1 f c (* otherwise parenthesize *)
-    | Labelled s -> pp f "%s:%a" s self#core_type1 c
-    | Optional s -> pp f "?%s:%a" s self#core_type1 c
-  method core_type f x =
-    if x.ptyp_attributes <> [] then begin
-      pp f "((%a)%a)" self#core_type {x with ptyp_attributes=[]}
-        self#attributes x.ptyp_attributes
-    end
-    else match x.ptyp_desc with
+            | x::xs ->  fu f x; pp f sep; loop f xs;
+            | _ -> assert false in begin
+            pp f first; loop f xs; pp f last;
+          end in
+    aux f xs
+
+let option : 'a. ?first:space_formatter -> ?last:space_formatter ->
+  (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit
+  = fun  ?first  ?last fu f a ->
+    let first = match first with Some x -> x | None -> ("": _ format6)
+    and last = match last with Some x -> x | None -> ("": _ format6) in
+    match a with
+    | None -> ()
+    | Some x -> pp f first; fu f x; pp f last
+
+let paren: 'a . ?first:space_formatter -> ?last:space_formatter ->
+  bool -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit
+  = fun  ?(first=("": _ format6)) ?(last=("": _ format6)) b fu f x ->
+    if b then (pp f "("; pp f first; fu f x; pp f last; pp f ")")
+    else fu f x
+
+let rec longident f = function
+  | Lident s -> protect_ident f s
+  | Ldot(y,s) -> protect_longident f longident y s
+  | Lapply (y,s) ->
+      pp f "%a(%a)" longident y longident s
+
+let longident_loc f x = pp f "%a" longident x.txt
+
+let 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_integer (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i
+  | Pconst_integer (i, Some m) ->
+    paren (i.[0]='-') (fun f (i, m) -> pp f "%s%c" i m) f (i,m)
+  | Pconst_float (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i
+  | Pconst_float (i, Some m) -> paren (i.[0]='-') (fun f (i,m) ->
+      pp f "%s%c" i m) f (i,m)
+
+(* trailing space*)
+let mutable_flag f = function
+  | Immutable -> ()
+  | Mutable -> pp f "mutable@;"
+let virtual_flag f  = function
+  | Concrete -> ()
+  | Virtual -> pp f "virtual@;"
+
+(* trailing space added *)
+let rec_flag f rf =
+  match rf with
+  | Nonrecursive -> ()
+  | Recursive -> pp f "rec "
+let nonrec_flag f rf =
+  match rf with
+  | Nonrecursive -> pp f "nonrec "
+  | Recursive -> ()
+let direction_flag f = function
+  | Upto -> pp f "to@ "
+  | Downto -> pp f "downto@ "
+let private_flag f = function
+  | Public -> ()
+  | Private -> pp f "private@ "
+
+let constant_string f s = pp f "%S" s
+let tyvar f str = pp f "'%s" str
+let string_quot f x = pp f "`%s" x
+
+(* c ['a,'b] *)
+let rec class_params_def ctxt f =  function
+  | [] -> ()
+  | l ->
+      pp f "[%a] " (* space *)
+        (list (type_param ctxt) ~sep:",") l
+
+and type_with_label ctxt f (label, c) =
+  match label with
+  | Nolabel    -> core_type1 ctxt f c (* otherwise parenthesize *)
+  | Labelled s -> pp f "%s:%a" s (core_type1 ctxt) c
+  | Optional s -> pp f "?%s:%a" s (core_type1 ctxt) c
+
+and core_type ctxt f x =
+  if x.ptyp_attributes <> [] then begin
+    pp f "((%a)%a)" (core_type ctxt) {x with ptyp_attributes=[]}
+      (attributes ctxt) x.ptyp_attributes
+  end
+  else match x.ptyp_desc with
     | Ptyp_arrow (l, ct1, ct2) ->
         pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
-          self#type_with_label (l,ct1) self#core_type ct2
+          (type_with_label ctxt) (l,ct1) (core_type ctxt) ct2
     | Ptyp_alias (ct, s) ->
-        pp f "@[<2>%a@;as@;'%s@]" self#core_type1 ct s
+        pp f "@[<2>%a@;as@;'%s@]" (core_type1 ctxt) ct s
     | Ptyp_poly (sl, ct) ->
         pp f "@[<2>%a%a@]"
           (fun f l ->
-            pp f "%a"
-              (fun f l -> match l with
-              | [] -> ()
-              | _ ->
-                  pp f "%a@;.@;"
-                    (self#list self#tyvar ~sep:"@;")  l)
-              l)
-          sl  self#core_type ct
-    | _ -> pp f "@[<2>%a@]" self#core_type1 x
-  method core_type1 f x =
-    if x.ptyp_attributes <> [] then self#core_type f x
-    else match x.ptyp_desc with
+             pp f "%a"
+               (fun f l -> match l with
+                  | [] -> ()
+                  | _ ->
+                      pp f "%a@;.@;"
+                        (list tyvar ~sep:"@;")  l)
+               l)
+          sl (core_type ctxt) ct
+    | _ -> pp f "@[<2>%a@]" (core_type1 ctxt) x
+
+and core_type1 ctxt f x =
+  if x.ptyp_attributes <> [] then core_type ctxt f x
+  else match x.ptyp_desc with
     | Ptyp_any -> pp f "_";
-    | Ptyp_var s -> self#tyvar f  s;
-    | Ptyp_tuple l ->  pp f "(%a)" (self#list self#core_type1 ~sep:"*@;") l
+    | Ptyp_var s -> tyvar f  s;
+    | Ptyp_tuple l ->  pp f "(%a)" (list (core_type1 ctxt) ~sep:"@;*@;") l
     | Ptyp_constr (li, l) ->
         pp f (* "%a%a@;" *) "%a%a"
           (fun f l -> match l with
-          |[] -> ()
-          |[x]-> pp f "%a@;" self#core_type1  x
-          | _ -> self#list ~first:"(" ~last:")@;" self#core_type ~sep:"," f l)
-          l self#longident_loc li
+             |[] -> ()
+             |[x]-> pp f "%a@;" (core_type1 ctxt)  x
+             | _ -> list ~first:"(" ~last:")@;" (core_type ctxt) ~sep:"," f l)
+          l longident_loc li
     | Ptyp_variant (l, closed, low) ->
         let type_variant_helper f x =
           match x with
-          | Rtag (l, attrs, _, ctl) -> pp f "@[<2>%a%a@;%a@]" self#string_quot l
+          | Rtag (l, attrs, _, ctl) ->
+              pp f "@[<2>%a%a@;%a@]" string_quot l
                 (fun f l -> match l with
-                |[] -> ()
-                | _ -> pp f "@;of@;%a"
-                      (self#list self#core_type ~sep:"&")  ctl) ctl
-                self#attributes attrs
-          | Rinherit ct -> self#core_type f ct in
+                   |[] -> ()
+                   | _ -> pp f "@;of@;%a"
+                            (list (core_type ctxt) ~sep:"&")  ctl) ctl
+                (attributes ctxt) attrs
+          | Rinherit ct -> core_type ctxt f ct in
         pp f "@[<2>[%a%a]@]"
-          (fun f l
-            ->
-              match l with
-              | [] -> ()
-              | _ ->
-              pp f "%s@;%a"
-                (match (closed,low) with
-                | (Closed,None) -> ""
-                | (Closed,Some _) -> "<" (* FIXME desugar the syntax sugar*)
-                | (Open,_) -> ">")
-                (self#list type_variant_helper ~sep:"@;<1 -2>| ") l) l
-          (fun f low
-            ->
-              match low with
-              |Some [] |None -> ()
-              |Some xs ->
-              pp f ">@ %a"
-                (self#list self#string_quot) xs) low
+          (fun f l ->
+             match l, closed with
+             | [], Closed -> ()
+             | [], Open -> pp f ">" (* Cf #7200: print [>] correctly *)
+             | _ ->
+                 pp f "%s@;%a"
+                   (match (closed,low) with
+                    | (Closed,None) -> ""
+                    | (Closed,Some _) -> "<" (* FIXME desugar the syntax sugar*)
+                    | (Open,_) -> ">")
+                   (list type_variant_helper ~sep:"@;<1 -2>| ") l) l
+          (fun f low -> match low with
+             |Some [] |None -> ()
+             |Some xs ->
+                 pp f ">@ %a"
+                   (list string_quot) xs) low
     | Ptyp_object (l, o) ->
         let core_field_type f (s, attrs, ct) =
-          pp f "@[%s%a@ :%a@ @]" s
-             self#attributes attrs self#core_type ct
+          pp f "@[%s: %a@ %a@ @]" s
+            (core_type ctxt) ct (attributes ctxt) attrs (* Cf #7200 *)
         in
         let field_var f = function
           | Asttypes.Closed -> ()
@@ -300,257 +309,277 @@ class printer  ()= object(self:'self)
               | [] -> pp f ".."
               | _ -> pp f " ;.."
         in
-        pp f "@[<@ %a%a@ >@]" (self#list core_field_type ~sep:";") l
-          field_var o
+        pp f "@[<@ %a%a@ > @]" (list core_field_type ~sep:";") l
+          field_var o (* Cf #7200 *)
     | Ptyp_class (li, l) ->   (*FIXME*)
         pp f "@[%a#%a@]"
-          (self#list self#core_type ~sep:"," ~first:"(" ~last:")") l
-          self#longident_loc li
+          (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") l
+          longident_loc li
     | Ptyp_package (lid, cstrs) ->
         let aux f (s, ct) =
-          pp f "type %a@ =@ %a" self#longident_loc s self#core_type ct  in
+          pp f "type %a@ =@ %a" longident_loc s (core_type ctxt) ct  in
         (match cstrs with
-        |[] -> pp f "@[(module@ %a)@]" self#longident_loc lid
-        |_ ->
-            pp f "@[(module@ %a@ with@ %a)@]" self#longident_loc lid
-              (self#list aux  ~sep:"@ and@ ")  cstrs)
-    | Ptyp_extension e -> self#extension f e
-    | _ -> self#paren true self#core_type f x
-          (********************pattern********************)
-          (* be cautious when use [pattern], [pattern1] is preferred *)
-  method pattern f x =
-    let rec list_of_pattern acc = function (* only consider ((A|B)|C)*)
-      | {ppat_desc= Ppat_or (p1,p2);_} ->
-          list_of_pattern  (p2::acc) p1
-      | x -> x::acc in
-    if x.ppat_attributes <> [] then begin
-      pp f "((%a)%a)" self#pattern {x with ppat_attributes=[]}
-        self#attributes x.ppat_attributes
-    end
-    else match x.ppat_desc with
-    | Ppat_alias (p, s) -> pp f "@[<2>%a@;as@;%a@]"
-          self#pattern p protect_ident s.txt (* RA*)
-    | Ppat_or (p1, p2) -> (* *)
-        pp f "@[%a@]" (self#list ~sep:"@,|" self#pattern)
-           (list_of_pattern [] x)
-    | _ -> self#pattern1 f x
-  method pattern1 (f:Format.formatter) (x:pattern) :unit =
-    let rec pattern_list_helper f  =  function
-      | {ppat_desc =
+         |[] -> pp f "@[(module@ %a)@]" longident_loc lid
+         |_ ->
+             pp f "@[(module@ %a@ with@ %a)@]" longident_loc lid
+               (list aux  ~sep:"@ and@ ")  cstrs)
+    | Ptyp_extension e -> extension ctxt f e
+    | _ -> paren true (core_type ctxt) f x
+
+(********************pattern********************)
+(* be cautious when use [pattern], [pattern1] is preferred *)
+and pattern ctxt f x =
+  let rec list_of_pattern acc = function (* only consider ((A|B)|C)*)
+    | {ppat_desc= Ppat_or (p1,p2);_} ->
+        list_of_pattern  (p2::acc) p1
+    | x -> x::acc
+  in
+  if x.ppat_attributes <> [] then begin
+    pp f "((%a)%a)" (pattern ctxt) {x with ppat_attributes=[]}
+      (attributes ctxt) x.ppat_attributes
+  end
+  else match x.ppat_desc with
+    | Ppat_alias (p, s) ->
+        pp f "@[<2>%a@;as@;%a@]" (pattern ctxt) p protect_ident s.txt (* RA*)
+    | Ppat_or _ -> (* *)
+        pp f "@[%a@]" (list ~sep:"@,|" (pattern ctxt))
+          (list_of_pattern [] x)
+    | _ -> pattern1 ctxt f x
+
+and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit =
+  let rec pattern_list_helper f = function
+    | {ppat_desc =
          Ppat_construct
            ({ txt = Lident("::") ;_},
             Some ({ppat_desc = Ppat_tuple([pat1; pat2]);_})); _}
-        -> pp f "%a::%a"  self#simple_pattern  pat1  pattern_list_helper pat2
-            (*RA*)
-      | p -> self#pattern1 f p in
-    if x.ppat_attributes <> [] then self#pattern f x
-    else match x.ppat_desc with
-    | Ppat_variant (l, Some p) ->  pp f "@[<2>`%s@;%a@]" l self#simple_pattern p
-    | Ppat_construct (({txt=Lident("()"|"[]");_}), _) -> self#simple_pattern f x
+      ->
+        pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*)
+    | p -> pattern1 ctxt f p
+  in
+  if x.ppat_attributes <> [] then pattern ctxt f x
+  else match x.ppat_desc with
+    | Ppat_variant (l, Some p) ->
+        pp f "@[<2>`%s@;%a@]" l (simple_pattern ctxt) p
+    | Ppat_construct (({txt=Lident("()"|"[]");_}), _) -> simple_pattern ctxt f x
     | Ppat_construct (({txt;_} as li), po) ->
         (* FIXME The third field always false *)
         if txt = Lident "::" then
           pp f "%a" pattern_list_helper x
         else
           (match po with
-          |Some x ->
-              pp f "%a@;%a"  self#longident_loc li self#simple_pattern x
-          | None -> pp f "%a@;"self#longident_loc li )
-    | _ -> self#simple_pattern f x
-  method simple_pattern (f:Format.formatter) (x:pattern) :unit =
-    if x.ppat_attributes <> [] then self#pattern f x
-    else match x.ppat_desc with
+           | Some x -> pp f "%a@;%a"  longident_loc li (simple_pattern ctxt) x
+           | None -> pp f "%a@;"longident_loc li )
+    | _ -> simple_pattern ctxt f x
+
+and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit =
+  if x.ppat_attributes <> [] then pattern ctxt f x
+  else match x.ppat_desc with
     | Ppat_construct (({txt=Lident ("()"|"[]" as x);_}), _) -> pp f  "%s" x
     | Ppat_any -> pp f "_";
     | Ppat_var ({txt = txt;_}) -> protect_ident f txt
     | Ppat_array l ->
-        pp f "@[<2>[|%a|]@]"  (self#list self#pattern1 ~sep:";") l
+        pp f "@[<2>[|%a|]@]"  (list (pattern1 ctxt) ~sep:";") l
     | Ppat_unpack (s) ->
         pp f "(module@ %s)@ " s.txt
     | Ppat_type li ->
-        pp f "#%a" self#longident_loc li
+        pp f "#%a" longident_loc li
     | Ppat_record (l, closed) ->
         let longident_x_pattern f (li, p) =
           match (li,p.ppat_desc) with
           | ({txt=Lident s;_ },Ppat_var {txt;_} ) when s = txt ->
-              pp f "@[<2>%a@]"  self#longident_loc li
+              pp f "@[<2>%a@]"  longident_loc li
           | _ ->
-            pp f "@[<2>%a@;=@;%a@]" self#longident_loc li self#pattern1 p in
-        (match closed with
-        |Closed ->
-            pp f "@[<2>{@;%a@;}@]"
-              (self#list longident_x_pattern ~sep:";@;") l
+              pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p
+        in
+        begin match closed with
+        | Closed ->
+            pp f "@[<2>{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l
         | _ ->
-            pp f "@[<2>{@;%a;_}@]"
-              (self#list longident_x_pattern ~sep:";@;") l)
-    | Ppat_tuple l -> pp f "@[<1>(%a)@]" (self#list  ~sep:"," self#pattern1)  l
-                      (* level1*)
-    | Ppat_constant (c) -> pp f "%a" self#constant c
-    | Ppat_interval (c1, c2) -> pp f "%a..%a" self#constant c1 self#constant c2
+            pp f "@[<2>{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l
+        end
+    | Ppat_tuple l ->
+        pp f "@[<1>(%a)@]" (list  ~sep:"," (pattern1 ctxt))  l (* level1*)
+    | Ppat_constant (c) -> pp f "%a" constant c
+    | Ppat_interval (c1, c2) -> pp f "%a..%a" constant c1 constant c2
     | Ppat_variant (l,None) ->  pp f "`%s" l
     | Ppat_constraint (p, ct) ->
-        pp f "@[<2>(%a@;:@;%a)@]" self#pattern1 p self#core_type ct
+        pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct
     | Ppat_lazy p ->
-        pp f "@[<2>(lazy@;%a)@]" self#pattern1 p
+        pp f "@[<2>(lazy@;%a)@]" (pattern1 ctxt) p
     | Ppat_exception p ->
-        pp f "@[<2>exception@;%a@]" self#pattern1 p
-    | Ppat_extension e -> self#extension f e
-    | _ -> self#paren true self#pattern f x
-
-  method label_exp f (l,opt,p) =
-    match l with
-    | Nolabel ->
-      pp f "%a@ " self#simple_pattern p
-        (*single case pattern parens needed here *)
-    | Optional rest ->
-        begin match p.ppat_desc with
-          | Ppat_var {txt;_} when txt = rest ->
-              (match opt with
-               | Some o -> pp f "?(%s=@;%a)@;" rest  self#expression o
-               | None -> pp f "?%s@ " rest)
-          | _ ->
-              (match opt with
-               | Some o ->
-                   pp f "?%s:(%a=@;%a)@;" rest self#pattern1 p self#expression o
-               | None -> pp f "?%s:%a@;" rest self#simple_pattern p)
-        end
-    | Labelled l ->
-        (match p.ppat_desc with
-        | Ppat_var {txt;_} when txt = l ->
-            pp f "~%s@;" l
-        | _ ->  pp f "~%s:%a@;" l self#simple_pattern p )
-  method sugar_expr f e =
-    if e.pexp_attributes <> [] then false
-    else match e.pexp_desc with
-    | Pexp_apply ({ pexp_desc = Pexp_ident { txt = id; _ };
-                    pexp_attributes=[]; _ }, args)
-      when List.for_all (fun (lab, _) -> lab = Nolabel) args -> begin
-        match id, List.map snd args with
-        | Lident "!", [e] ->
-          pp f "@[!%a@]" self#simple_expr e;
-          true
-        | Ldot (path, ("get"|"set" as func)), a :: other_args -> begin
-            let print left right print_index indexes rem_args =
-              match func, rem_args with
-              | "get", [] ->
-                pp f "@[%a.%s%a%s@]"
-                  self#simple_expr a
-                  left (self#list ~sep:"," print_index) indexes right;
-                true
-              | "set", [v] ->
-                pp f "@[%a.%s%a%s@ <-@;<1 2>%a@]"
-                  self#simple_expr a
-                  left (self#list ~sep:"," print_index) indexes right
-                  self#simple_expr v;
-                true
-              | _ -> false
-            in
-            match path, other_args with
-            | Lident "Array", i :: rest ->
-              print "(" ")" self#expression [i] rest
-            | Lident "String", i :: rest ->
-              print "[" "]" self#expression [i] rest
-            | Ldot (Lident "Bigarray", "Array1"), i1 :: rest ->
-              print "{" "}" self#simple_expr [i1] rest
-            | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest ->
-              print "{" "}" self#simple_expr [i1; i2] rest
-            | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest ->
-              print "{" "}" self#simple_expr [i1; i2; i3] rest
-            | Ldot (Lident "Bigarray", "Genarray"),
-              {pexp_desc = Pexp_array indexes; pexp_attributes = []} :: rest ->
-              print "{" "}" self#simple_expr indexes rest
-            | _ -> false
-          end
-        | _ -> false
+        pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p
+    | Ppat_extension e -> extension ctxt f e
+    | Ppat_open (lid, p) ->
+        let with_paren =
+        match p.ppat_desc with
+        | Ppat_array _ | Ppat_record _
+        | Ppat_construct (({txt=Lident ("()"|"[]");_}), _) -> false
+        | _ -> true in
+        pp f "@[<2>%a.%a @]" longident_loc lid
+          (paren with_paren @@ pattern1 ctxt) p
+    | _ -> paren true (pattern ctxt) f x
+
+and label_exp ctxt f (l,opt,p) =
+  match l with
+  | Nolabel ->
+      (* single case pattern parens needed here *)
+      pp f "%a@ " (simple_pattern ctxt) p
+  | Optional rest ->
+      begin match p.ppat_desc with
+      | Ppat_var {txt;_} when txt = rest ->
+          (match opt with
+           | Some o -> pp f "?(%s=@;%a)@;" rest  (expression ctxt) o
+           | None -> pp f "?%s@ " rest)
+      | _ ->
+          (match opt with
+           | Some o ->
+               pp f "?%s:(%a=@;%a)@;"
+                 rest (pattern1 ctxt) p (expression ctxt) o
+           | None -> pp f "?%s:%a@;" rest (simple_pattern ctxt) p)
       end
-    | _ -> false
-  method expression f x =
-    if x.pexp_attributes <> [] then begin
-      pp f "((%a)@,%a)" self#expression {x with pexp_attributes=[]}
-        self#attributes x.pexp_attributes
+  | Labelled l -> match p.ppat_desc with
+    | Ppat_var {txt;_} when txt = l ->
+        pp f "~%s@;" l
+    | _ ->  pp f "~%s:%a@;" l (simple_pattern ctxt) p
+
+and sugar_expr ctxt f e =
+  if e.pexp_attributes <> [] then false
+  else match e.pexp_desc with
+  | Pexp_apply ({ pexp_desc = Pexp_ident {txt = id; _};
+                  pexp_attributes=[]; _}, args)
+    when List.for_all (fun (lab, _) -> lab = Nolabel) args -> begin
+      match id, List.map snd args with
+      | Lident "!", [e] ->
+        pp f "@[!%a@]" (simple_expr ctxt) e; true
+      | Ldot (path, ("get"|"set" as func)), a :: other_args -> begin
+          let print left right print_index indexes rem_args =
+            match func, rem_args with
+            | "get", [] ->
+              pp f "@[%a.%s%a%s@]"
+                (simple_expr ctxt) a
+                left (list ~sep:"," print_index) indexes right; true
+            | "set", [v] ->
+              pp f "@[%a.%s%a%s@ <-@;<1 2>%a@]"
+                (simple_expr ctxt) a
+                left (list ~sep:"," print_index) indexes right
+                (simple_expr ctxt) v; true
+            | _ -> false
+          in
+          match path, other_args with
+          | Lident "Array", i :: rest ->
+            print "(" ")" (expression ctxt) [i] rest
+          | Lident "String", i :: rest ->
+            print "[" "]" (expression ctxt) [i] rest
+          | Ldot (Lident "Bigarray", "Array1"), i1 :: rest ->
+            print "{" "}" (simple_expr ctxt) [i1] rest
+          | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest ->
+            print "{" "}" (simple_expr ctxt) [i1; i2] rest
+          | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest ->
+            print "{" "}" (simple_expr ctxt) [i1; i2; i3] rest
+          | Ldot (Lident "Bigarray", "Genarray"),
+            {pexp_desc = Pexp_array indexes; pexp_attributes = []} :: rest ->
+            print "{" "}" (simple_expr ctxt) indexes rest
+          | _ -> false
+        end
+      | _ -> false
     end
-    else match x.pexp_desc with
+  | _ -> false
+
+and expression ctxt f x =
+  if x.pexp_attributes <> [] then
+    pp f "((%a)@,%a)" (expression ctxt) {x with pexp_attributes=[]}
+      (attributes ctxt) x.pexp_attributes
+  else match x.pexp_desc with
     | Pexp_function _ | Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _
-      when pipe || semi ->
-        self#paren true self#reset#expression f x
-    | Pexp_ifthenelse _ | Pexp_sequence _ when ifthenelse ->
-        self#paren true self#reset#expression f x
-    | Pexp_let _ | Pexp_letmodule _ | Pexp_open _ when semi ->
-        self#paren true self#reset#expression f x
+      when ctxt.pipe || ctxt.semi ->
+        paren true (expression reset_ctxt) f x
+    | Pexp_ifthenelse _ | Pexp_sequence _ when ctxt.ifthenelse ->
+        paren true (expression reset_ctxt) f x
+    | Pexp_let _ | Pexp_letmodule _ | Pexp_open _ | Pexp_letexception _
+        when ctxt.semi ->
+        paren true (expression reset_ctxt) f x
     | Pexp_fun (l, e0, p, e) ->
         pp f "@[<2>fun@;%a@;->@;%a@]"
-          self#label_exp (l, e0, p)
-          self#expression e
+          (label_exp ctxt) (l, e0, p)
+          (expression ctxt) e
     | Pexp_function l ->
-        pp f "@[function%a@]" self#case_list l
+        pp f "@[function%a@]" (case_list ctxt) l
     | Pexp_match (e, l) ->
-        pp f "@[@[@[<2>match %a@]@ with@]%a@]" self#reset#expression
-           e self#case_list l
+        pp f "@[@[@[<2>match %a@]@ with@]%a@]"
+          (expression reset_ctxt) e (case_list ctxt) l
 
     | Pexp_try (e, l) ->
         pp f "@[<0>@[try@ %a@]@ @[<0>with%a@]@]"
-          (* "try@;@[<2>%a@]@\nwith@\n%a"*)
-          self#reset#expression e  self#case_list l
+             (* "try@;@[<2>%a@]@\nwith@\n%a"*)
+          (expression reset_ctxt) e  (case_list ctxt) l
     | Pexp_let (rf, l, e) ->
         (* pp f "@[<2>let %a%a in@;<1 -2>%a@]"
            (*no identation here, a new line*) *)
-        (*   self#rec_flag rf *)
+        (*   rec_flag rf *)
         pp f "@[<2>%a in@;<1 -2>%a@]"
-          self#reset#bindings (rf,l)
-          self#expression e
+          (bindings reset_ctxt) (rf,l)
+          (expression ctxt) e
     | Pexp_apply (e, l) ->
-        (if not (self#sugar_expr f x) then
-          match view_fixity_of_exp e with
-          | `Infix s ->
-            (match l with
-            | [ (Nolabel, _) as arg1; (Nolabel, _) as arg2 ] ->
-                pp f "@[<2>%a@;%s@;%a@]"
-                   (* FIXME associativity lable_x_expression_parm*)
-                   self#reset#label_x_expression_param  arg1 s
-                   self#label_x_expression_param arg2
+        begin if not (sugar_expr ctxt f x) then
+            match view_fixity_of_exp e with
+            | `Infix s ->
+                begin match l with
+                | [ (Nolabel, _) as arg1; (Nolabel, _) as arg2 ] ->
+                    (* FIXME associativity label_x_expression_param *)
+                    pp f "@[<2>%a@;%s@;%a@]"
+                      (label_x_expression_param reset_ctxt) arg1 s
+                      (label_x_expression_param ctxt) arg2
+                | _ ->
+                    pp f "@[<2>%a %a@]"
+                      (simple_expr ctxt) e
+                      (list (label_x_expression_param ctxt)) l
+                end
+            | `Prefix s ->
+                let s =
+                  if List.mem s ["~+";"~-";"~+.";"~-."] &&
+                   (match l with
+                    (* See #7200: avoid turning (~- 1) into (- 1) which is
+                       parsed as an int literal *)
+                    |[(_,{pexp_desc=Pexp_constant _})] -> false
+                    | _ -> true)
+                  then String.sub s 1 (String.length s -1)
+                  else s in
+                begin match l with
+                | [(Nolabel, _) as v] ->
+                  pp f "@[<2>%s@;%a@]" s (label_x_expression_param ctxt) v
+                | _   ->
+                  pp f "@[<2>%a %a@]" (simple_expr ctxt) e
+                    (list (label_x_expression_param ctxt)) l
+                end
             | _ ->
-                pp f "@[<2>%a %a@]" self#simple_expr e
-                   (self#list self#label_x_expression_param)  l)
-          | `Prefix s ->
-              let s =
-                if List.mem s ["~+";"~-";"~+.";"~-."]
-                then String.sub s 1 (String.length s -1)
-                else s
-            in
-            (match l with
-            | [(Nolabel, _) as v] ->
-              pp f "@[<2>%s@;%a@]" s self#label_x_expression_param v
-            | _ ->
-              pp f "@[<2>%a %a@]" self#simple_expr e
-                (self#list self#label_x_expression_param) l
-            )
-          | _ ->
-            pp f "@[%a@]" begin fun f (e,l) ->
-              pp f "%a@ %a" self#expression2 e
-                (self#list self#reset#label_x_expression_param) l
-               (*reset here only because [function,match,try,sequence] are
-                 lower priority*)
-            end (e,l))
+                pp f "@[%a@]" begin fun f (e,l) ->
+                  pp f "%a@ %a" (expression2 ctxt) e
+                    (list (label_x_expression_param reset_ctxt))  l
+                    (* reset here only because [function,match,try,sequence]
+                       are lower priority *)
+                end (e,l)
+        end
 
     | Pexp_construct (li, Some eo)
       when not (is_simple_construct (view_expr x))-> (* Not efficient FIXME*)
         (match view_expr x with
-        | `cons ls -> self#list self#simple_expr f ls ~sep:"@;::@;"
-        | `normal ->
-            pp f "@[<2>%a@;%a@]" self#longident_loc li
-              self#simple_expr  eo
-        | _ -> assert false)
+         | `cons ls -> list (simple_expr ctxt) f ls ~sep:"@;::@;"
+         | `normal ->
+             pp f "@[<2>%a@;%a@]" longident_loc li
+               (simple_expr ctxt) eo
+         | _ -> assert false)
     | Pexp_setfield (e1, li, e2) ->
-        pp f "@[<2>%a.%a@ <-@ %a@]" self#simple_expr  e1  self#longident_loc li
-           self#expression e2;
+        pp f "@[<2>%a.%a@ <-@ %a@]"
+          (simple_expr ctxt) e1 longident_loc li (expression ctxt) e2
     | Pexp_ifthenelse (e1, e2, eo) ->
         (* @;@[<2>else@ %a@]@] *)
         let fmt:(_,_,_)format ="@[@[<2>if@ %a@]@;@[<2>then@ %a@]%a@]" in
-        pp f fmt  self#under_ifthenelse#expression e1
-           self#under_ifthenelse#expression e2
+        let expression_under_ifthenelse = expression (under_ifthenelse ctxt) in
+        pp f fmt expression_under_ifthenelse e1 expression_under_ifthenelse e2
           (fun f eo -> match eo with
-          | Some x -> pp f "@;@[<2>else@;%a@]" self#under_semi#expression  x
-          | None -> () (* pp f "()" *)) eo
+             | Some x ->
+                 pp f "@;@[<2>else@;%a@]" (expression (under_semi ctxt)) x
+             | None -> () (* pp f "()" *)) eo
     | Pexp_sequence _ ->
         let rec sequence_helper acc = function
           | {pexp_desc=Pexp_sequence(e1,e2);_} ->
@@ -558,864 +587,860 @@ class printer  ()= object(self:'self)
           | v -> List.rev (v::acc) in
         let lst = sequence_helper [] x in
         pp f "@[%a@]"
-          (self#list self#under_semi#expression ~sep:";@;") lst
+          (list (expression (under_semi ctxt)) ~sep:";@;") lst
     | Pexp_new (li) ->
-        pp f "@[new@ %a@]" self#longident_loc li;
+        pp f "@[new@ %a@]" longident_loc li;
     | Pexp_setinstvar (s, e) ->
-        pp f "@[%s@ <-@ %a@]" s.txt self#expression e
+        pp f "@[%s@ <-@ %a@]" s.txt (expression ctxt) e
     | Pexp_override l -> (* FIXME *)
         let string_x_expression f (s, e) =
-          pp f "@[%s@ =@ %a@]" s.txt self#expression e in
+          pp f "@[%s@ =@ %a@]" s.txt (expression ctxt) e in
         pp f "@[{<%a>}@]"
-          (self#list string_x_expression  ~sep:";"  )  l;
+          (list string_x_expression  ~sep:";"  )  l;
     | Pexp_letmodule (s, me, e) ->
         pp f "@[let@ module@ %s@ =@ %a@ in@ %a@]" s.txt
-          self#reset#module_expr me  self#expression e
+          (module_expr reset_ctxt) me (expression ctxt) e
+    | Pexp_letexception (cd, e) ->
+        pp f "@[let@ exception@ %a@ in@ %a@]"
+          (extension_constructor ctxt) cd
+          (expression ctxt) e
     | Pexp_assert e ->
-        pp f "@[assert@ %a@]" self#simple_expr e
+        pp f "@[assert@ %a@]" (simple_expr ctxt) e
     | Pexp_lazy (e) ->
-        pp f "@[lazy@ %a@]" self#simple_expr e
-    (* Pexp_poly: impossible but we should print it anyway, rather
-       than assert false *)
+        pp f "@[lazy@ %a@]" (simple_expr ctxt) e
+    (* Pexp_poly: impossible but we should print it anyway, rather than
+       assert false *)
     | Pexp_poly (e, None) ->
-        pp f "@[!poly!@ %a@]" self#simple_expr e
+        pp f "@[!poly!@ %a@]" (simple_expr ctxt) e
     | Pexp_poly (e, Some ct) ->
-        pp f "@[(!poly!@ %a@ : %a)@]" self#simple_expr e self#core_type ct
+        pp f "@[(!poly!@ %a@ : %a)@]"
+          (simple_expr ctxt) e (core_type ctxt) ct
     | Pexp_open (ovf, lid, e) ->
-        pp f "@[<2>let open%s %a in@;%a@]" (override ovf) self#longident_loc lid
-          self#expression  e
+        pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid
+          (expression ctxt) e
     | Pexp_variant (l,Some eo) ->
-        pp f "@[<2>`%s@;%a@]" l  self#simple_expr eo
-    | Pexp_extension e -> self#extension f e
-    | Pexp_unreachable ->
-        pp f "."
-    | _ -> self#expression1 f x
-  method expression1 f x =
-    if x.pexp_attributes <> [] then self#expression f x
-    else match x.pexp_desc with
-    | Pexp_object cs -> pp f "%a" self#class_structure cs
-    | _ -> self#expression2 f x
-  (* used in [Pexp_apply] *)
-  method expression2 f x =
-    if x.pexp_attributes <> [] then self#expression f x
-    else match x.pexp_desc with
+        pp f "@[<2>`%s@;%a@]" l (simple_expr ctxt) eo
+    | Pexp_extension e -> extension ctxt f e
+    | Pexp_unreachable -> pp f "."
+    | _ -> expression1 ctxt f x
+
+and expression1 ctxt f x =
+  if x.pexp_attributes <> [] then expression ctxt f x
+  else match x.pexp_desc with
+    | Pexp_object cs -> pp f "%a" (class_structure ctxt) cs
+    | _ -> expression2 ctxt f x
+(* used in [Pexp_apply] *)
+
+and expression2 ctxt f x =
+  if x.pexp_attributes <> [] then expression ctxt f x
+  else match x.pexp_desc with
     | Pexp_field (e, li) ->
-        pp f "@[%a.%a@]" self#simple_expr e self#longident_loc li
-    | Pexp_send (e, s) ->  pp f "@[%a#%s@]" self#simple_expr e  s
+        pp f "@[%a.%a@]" (simple_expr ctxt) e longident_loc li
+    | Pexp_send (e, s) -> pp f "@[%a#%s@]" (simple_expr ctxt) e s
 
-    | _ -> self#simple_expr f x
-  method simple_expr f x =
-    if x.pexp_attributes <> [] then self#expression f x
-    else match x.pexp_desc with
+    | _ -> simple_expr ctxt f x
+
+and simple_expr ctxt f x =
+  if x.pexp_attributes <> [] then expression ctxt f x
+  else match x.pexp_desc with
     | Pexp_construct _  when is_simple_construct (view_expr x) ->
         (match view_expr x with
-        | `nil -> pp f "[]"
-        | `tuple -> pp f "()"
-        | `list xs ->
-            pp f "@[[%a]@]"
-               (self#list self#under_semi#expression ~sep:";@;") xs
-        | `simple x -> self#longident f x
-        | _ -> assert false)
+         | `nil -> pp f "[]"
+         | `tuple -> pp f "()"
+         | `list xs ->
+             pp f "@[[%a]@]"
+               (list (expression (under_semi ctxt)) ~sep:";@;") xs
+         | `simple x -> longident f x
+         | _ -> assert false)
     | Pexp_ident li ->
-        self#longident_loc f li
-        (* (match view_fixity_of_exp x with *)
-        (* |`Normal -> self#longident_loc f li *)
-        (* | `Prefix _ | `Infix _ -> pp f "( %a )" self#longident_loc li) *)
-    | Pexp_constant c -> self#constant f c;
+        longident_loc f li
+    (* (match view_fixity_of_exp x with *)
+    (* |`Normal -> longident_loc f li *)
+    (* | `Prefix _ | `Infix _ -> pp f "( %a )" longident_loc li) *)
+    | Pexp_constant c -> constant f c;
     | Pexp_pack me ->
-        pp f "(module@;%a)"  self#module_expr me
+        pp f "(module@;%a)" (module_expr ctxt) me
     | Pexp_newtype (lid, e) ->
-        pp f "fun@;(type@;%s)@;->@;%a"  lid  self#expression  e
+        pp f "fun@;(type@;%s)@;->@;%a" lid (expression ctxt) e
     | Pexp_tuple l ->
-        pp f "@[(%a)@]"  (self#list self#simple_expr  ~sep:",@;")  l
+        pp f "@[(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l
     | Pexp_constraint (e, ct) ->
-        pp f "(%a : %a)" self#expression e self#core_type ct
+        pp f "(%a : %a)" (expression ctxt) e (core_type ctxt) ct
     | Pexp_coerce (e, cto1, ct) ->
-        pp f "(%a%a :> %a)" self#expression e
-          (self#option self#core_type ~first:" : " ~last:" ")
-          cto1 (* no sep hint*)
-          self#core_type ct
+        pp f "(%a%a :> %a)" (expression ctxt) e
+          (option (core_type ctxt) ~first:" : " ~last:" ") cto1 (* no sep hint*)
+          (core_type ctxt) ct
     | Pexp_variant (l, None) -> pp f "`%s" l
     | Pexp_record (l, eo) ->
         let longident_x_expression f ( li, e) =
           match e.pexp_desc with
           |  Pexp_ident {txt;_} when li.txt = txt ->
-              pp f "@[%a@]" self#longident_loc li
+              pp f "@[%a@]" longident_loc li
           | _ ->
-              pp f "@[%a@;=@;%a@]" self#longident_loc li self#simple_expr
-                 e
+              pp f "@[%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e
         in
         pp f "@[@[{@;%a%a@]@;}@]"(* "@[{%a%a}@]" *)
-          (self#option ~last:" with@;" self#simple_expr) eo
-          (self#list longident_x_expression ~sep:";@;")  l
+          (option ~last:" with@;" (simple_expr ctxt)) eo
+          (list longident_x_expression ~sep:";@;") l
     | Pexp_array (l) ->
         pp f "@[<0>@[<2>[|%a|]@]@]"
-          (self#list self#under_semi#simple_expr ~sep:";") l
+          (list (simple_expr (under_semi ctxt)) ~sep:";") l
     | Pexp_while (e1, e2) ->
-        let fmt:(_,_,_)format = "@[<2>while@;%a@;do@;%a@;done@]" in
-        pp f fmt self#expression e1 self#expression e2
+        let fmt : (_,_,_) format = "@[<2>while@;%a@;do@;%a@;done@]" in
+        pp f fmt (expression ctxt) e1 (expression ctxt) e2
     | Pexp_for (s, e1, e2, df, e3) ->
         let fmt:(_,_,_)format =
           "@[@[@[<2>for %a =@;%a@;%a%a@;do@]@;%a@]@;done@]" in
-        pp f fmt self#pattern s self#expression e1 self#direction_flag df
-           self#expression e2  self#expression e3
-    | _ ->  self#paren true self#expression f x
-
-  method attributes f l =
-    List.iter (self # attribute f) l
-
-  method item_attributes f l =
-    List.iter (self # item_attribute f) l
-
-  method attribute f (s, e) =
-    pp f "@[<2>[@@%s@ %a]@]" s.txt self#payload e
-
-  method item_attribute f (s, e) =
-    pp f "@[<2>[@@@@%s@ %a]@]" s.txt self#payload e
-
-  method floating_attribute f (s, e) =
-    pp f "@[<2>[@@@@@@%s@ %a]@]" s.txt self#payload e
-
-  method value_description f x =
-    (* note: value_description has an attribute field,
-       but they're already printed by the callers this method *)
-    pp f "@[%a%a@]" self#core_type x.pval_type
-      (fun f x ->
-        if x.pval_prim<>[] then begin
-          pp f "@ =@ %a"
-            (self#list self#constant_string)
-            x.pval_prim ;
-        end) x
-
-  method extension f (s, e) =
-    pp f "@[<2>[%%%s@ %a]@]" s.txt self#payload e
-
-  method item_extension f (s, e) =
-    pp f "@[<2>[%%%%%s@ %a]@]" s.txt self#payload e
-
-  method exception_declaration f ext =
-    pp f "@[exception@ %a@]" self#extension_constructor ext
-
-  method class_signature f { pcsig_self = ct; pcsig_fields = l ;_} =
-    let class_type_field f x =
-      match x.pctf_desc with
-      | Pctf_inherit (ct) ->
-          pp f "@[<2>inherit@ %a@]%a" self#class_type ct
-            self#item_attributes x.pctf_attributes
-      | Pctf_val (s, mf, vf, ct) ->
-          pp f "@[<2>val @ %a%a%s@ :@ %a@]%a"
-            self#mutable_flag mf self#virtual_flag vf s  self#core_type  ct
-            self#item_attributes x.pctf_attributes
-      | Pctf_method (s, pf, vf, ct) ->
-          pp f "@[<2>method %a %a%s :@;%a@]%a"
-            self#private_flag pf self#virtual_flag vf s self#core_type ct
-            self#item_attributes x.pctf_attributes
-      | Pctf_constraint (ct1, ct2) ->
-          pp f "@[<2>constraint@ %a@ =@ %a@]%a"
-            self#core_type ct1 self#core_type ct2
-            self#item_attributes x.pctf_attributes
-      | Pctf_attribute a -> self#floating_attribute f a
-      | Pctf_extension e ->
-          self#item_extension f e;
-          self#item_attributes f x.pctf_attributes
-    in
-    pp f "@[@[object@[<1>%a@]@ %a@]@ end@]"
-      (fun f ct -> match ct.ptyp_desc with
-      | Ptyp_any -> ()
-      | _ -> pp f " (%a)" self#core_type ct) ct
-      (self#list   class_type_field ~sep:"@;") l  ;
-
-  (* call [class_signature] called by [class_signature] *)
-  method class_type f x =
-    match x.pcty_desc with
-    | Pcty_signature cs ->
-        self#class_signature f cs;
-        self#attributes f x.pcty_attributes
-    | Pcty_constr (li, l) ->
-        pp f "%a%a%a"
-          (fun f l -> match l with
-          | [] -> ()
-          | _  -> pp f "[%a]@ " (self#list self#core_type ~sep:"," ) l) l
-          self#longident_loc li
-          self#attributes x.pcty_attributes
-    | Pcty_arrow (l, co, cl) ->
-        pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
-          self#type_with_label (l,co)
-          self#class_type cl
-    | Pcty_extension e ->
-        self#extension f e;
-        self#attributes f x.pcty_attributes
-
-  (* [class type a = object end] *)
-  method class_type_declaration_list f  l =
-    let class_type_declaration kwd f ({pci_params=ls;pci_name={txt;_};_} as x) =
-      pp f "@[<2>%s %a%a%s@ =@ %a@]%a" kwd
-        self#virtual_flag x.pci_virt
-        self#class_params_def ls txt
-        self#class_type x.pci_expr
-        self#item_attributes x.pci_attributes
-    in
-    match l with
-    | [] -> ()
-    | [x] -> class_type_declaration "class type" f x
-    | x :: xs ->
-        pp f "@[%a@,%a@]"
-          (class_type_declaration "class type") x
-          (self#list ~sep:"@," (class_type_declaration "and")) xs
-
-  method class_field f x =
-    match x.pcf_desc with
-    | Pcf_inherit (ovf, ce, so) ->
-        pp f "@[<2>inherit@ %s@ %a%a@]%a" (override ovf)
-          self#class_expr ce
-          (fun f so -> match so with
-          | None -> ();
-          | Some (s) -> pp f "@ as %s" s ) so
-          self#item_attributes x.pcf_attributes
-    | Pcf_val (s, mf, Cfk_concrete (ovf, e)) ->
-        pp f "@[<2>val%s %a%s =@;%a@]%a" (override ovf)
-          self#mutable_flag mf s.txt
-          self#expression  e
-          self#item_attributes x.pcf_attributes
-    | Pcf_method (s, pf, Cfk_virtual ct) ->
-        pp f "@[<2>method virtual %a %s :@;%a@]%a"
-          self#private_flag pf s.txt
-          self#core_type  ct
-          self#item_attributes x.pcf_attributes
-    | Pcf_val (s, mf, Cfk_virtual ct) ->
-        pp f "@[<2>val virtual %a%s :@ %a@]%a"
-          self#mutable_flag mf s.txt
-          self#core_type  ct
-          self#item_attributes x.pcf_attributes
-    | Pcf_method (s, pf, Cfk_concrete (ovf, e)) ->
-        let bind e =
-          self#binding f
-            {pvb_pat=
-               {ppat_desc=Ppat_var s;ppat_loc=Location.none;ppat_attributes=[]};
-             pvb_expr=e;
-             pvb_attributes=[];
-             pvb_loc=Location.none;
-            }
-        in
-        pp f "@[<2>method%s %a%a@]%a"
-          (override ovf)
-          self#private_flag pf
-          (fun f e -> match e.pexp_desc with
-          | Pexp_poly (e, Some ct) ->
-              pp f "%s :@;%a=@;%a"
-                s.txt (self#core_type) ct self#expression e
-          | Pexp_poly (e,None) -> bind e
-          | _ -> bind e) e
-          self#item_attributes x.pcf_attributes
-    | Pcf_constraint (ct1, ct2) ->
-        pp f "@[<2>constraint %a =@;%a@]%a"
-          self#core_type ct1
-          self#core_type ct2
-          self#item_attributes x.pcf_attributes
-    | Pcf_initializer (e) ->
-        pp f "@[<2>initializer@ %a@]%a"
-          self#expression e
-          self#item_attributes x.pcf_attributes
-    | Pcf_attribute a -> self#floating_attribute f a
-    | Pcf_extension e ->
-        self#item_extension f e;
-        self#item_attributes f x.pcf_attributes
-
-  method class_structure f { pcstr_self = p; pcstr_fields =  l } =
-    pp f "@[@[object%a@;%a@]@;end@]"
-      (fun f p -> match p.ppat_desc with
-      | Ppat_any -> ()
-      | Ppat_constraint _ -> pp f " %a"  self#pattern  p
-      | _ -> pp f " (%a)" self#pattern p) p
-      (self#list self#class_field ) l
-
-  method class_expr f x =
-    if x.pcl_attributes <> [] then begin
-      pp f "((%a)%a)" self#class_expr {x with pcl_attributes=[]}
-        self#attributes x.pcl_attributes
-    end else
+        let expression = expression ctxt in
+        pp f fmt (pattern ctxt) s expression e1 direction_flag
+          df expression e2 expression e3
+    | _ ->  paren true (expression ctxt) f x
+
+and attributes ctxt f l =
+  List.iter (attribute ctxt f) l
+
+and item_attributes ctxt f l =
+  List.iter (item_attribute ctxt f) l
+
+and attribute ctxt f (s, e) =
+  pp f "@[<2>[@@%s@ %a]@]" s.txt (payload ctxt) e
+
+and item_attribute ctxt f (s, e) =
+  pp f "@[<2>[@@@@%s@ %a]@]" s.txt (payload ctxt) e
+
+and floating_attribute ctxt f (s, e) =
+  pp f "@[<2>[@@@@@@%s@ %a]@]" s.txt (payload ctxt) e
+
+and value_description ctxt f x =
+  (* note: value_description has an attribute field,
+           but they're already printed by the callers this method *)
+  pp f "@[%a%a@]" (core_type ctxt) x.pval_type
+    (fun f x ->
+       if x.pval_prim <> []
+       then pp f "@ =@ %a" (list constant_string) x.pval_prim
+    ) x
+
+and extension ctxt f (s, e) =
+  pp f "@[<2>[%%%s@ %a]@]" s.txt (payload ctxt) e
+
+and item_extension ctxt f (s, e) =
+  pp f "@[<2>[%%%%%s@ %a]@]" s.txt (payload ctxt) e
+
+and exception_declaration ctxt f ext =
+  pp f "@[exception@ %a@]" (extension_constructor ctxt) ext
+
+and class_signature ctxt f { pcsig_self = ct; pcsig_fields = l ;_} =
+  let class_type_field f x =
+    match x.pctf_desc with
+    | Pctf_inherit (ct) ->
+        pp f "@[<2>inherit@ %a@]%a" (class_type ctxt) ct
+          (item_attributes ctxt) x.pctf_attributes
+    | Pctf_val (s, mf, vf, ct) ->
+        pp f "@[<2>val @ %a%a%s@ :@ %a@]%a"
+          mutable_flag mf virtual_flag vf s (core_type ctxt) ct
+          (item_attributes ctxt) x.pctf_attributes
+    | Pctf_method (s, pf, vf, ct) ->
+        pp f "@[<2>method %a %a%s :@;%a@]%a"
+          private_flag pf virtual_flag vf s (core_type ctxt) ct
+          (item_attributes ctxt) x.pctf_attributes
+    | Pctf_constraint (ct1, ct2) ->
+        pp f "@[<2>constraint@ %a@ =@ %a@]%a"
+          (core_type ctxt) ct1 (core_type ctxt) ct2
+          (item_attributes ctxt) x.pctf_attributes
+    | Pctf_attribute a -> floating_attribute ctxt f a
+    | Pctf_extension e ->
+        item_extension ctxt f e;
+        item_attributes ctxt f x.pctf_attributes
+  in
+  pp f "@[@[object@[<1>%a@]@ %a@]@ end@]"
+    (fun f ct -> match ct.ptyp_desc with
+       | Ptyp_any -> ()
+       | _ -> pp f " (%a)" (core_type ctxt) ct) ct
+    (list class_type_field ~sep:"@;") l
+
+(* call [class_signature] called by [class_signature] *)
+and class_type ctxt f x =
+  match x.pcty_desc with
+  | Pcty_signature cs ->
+      class_signature ctxt f cs;
+      attributes ctxt f x.pcty_attributes
+  | Pcty_constr (li, l) ->
+      pp f "%a%a%a"
+        (fun f l -> match l with
+           | [] -> ()
+           | _  -> pp f "[%a]@ " (list (core_type ctxt) ~sep:"," ) l) l
+        longident_loc li
+        (attributes ctxt) x.pcty_attributes
+  | Pcty_arrow (l, co, cl) ->
+      pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
+        (type_with_label ctxt) (l,co)
+        (class_type ctxt) cl
+  | Pcty_extension e ->
+      extension ctxt f e;
+      attributes ctxt f x.pcty_attributes
+
+(* [class type a = object end] *)
+and class_type_declaration_list ctxt f l =
+  let class_type_declaration kwd f x =
+    let { pci_params=ls; pci_name={ txt; _ }; _ } = x in
+    pp f "@[<2>%s %a%a%s@ =@ %a@]%a" kwd
+      virtual_flag x.pci_virt
+      (class_params_def ctxt) ls txt
+      (class_type ctxt) x.pci_expr
+      (item_attributes ctxt) x.pci_attributes
+  in
+  match l with
+  | [] -> ()
+  | [x] -> class_type_declaration "class type" f x
+  | x :: xs ->
+      pp f "@[%a@,%a@]"
+        (class_type_declaration "class type") x
+        (list ~sep:"@," (class_type_declaration "and")) xs
+
+and class_field ctxt f x =
+  match x.pcf_desc with
+  | Pcf_inherit (ovf, ce, so) ->
+      pp f "@[<2>inherit@ %s@ %a%a@]%a" (override ovf)
+        (class_expr ctxt) ce
+        (fun f so -> match so with
+           | None -> ();
+           | Some (s) -> pp f "@ as %s" s ) so
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_val (s, mf, Cfk_concrete (ovf, e)) ->
+      pp f "@[<2>val%s %a%s =@;%a@]%a" (override ovf)
+        mutable_flag mf s.txt
+        (expression ctxt) e
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_method (s, pf, Cfk_virtual ct) ->
+      pp f "@[<2>method virtual %a %s :@;%a@]%a"
+        private_flag pf s.txt
+        (core_type ctxt) ct
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_val (s, mf, Cfk_virtual ct) ->
+      pp f "@[<2>val virtual %a%s :@ %a@]%a"
+        mutable_flag mf s.txt
+        (core_type ctxt) ct
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_method (s, pf, Cfk_concrete (ovf, e)) ->
+      let bind e =
+        binding ctxt f
+          {pvb_pat=
+             {ppat_desc=Ppat_var s;ppat_loc=Location.none;ppat_attributes=[]};
+           pvb_expr=e;
+           pvb_attributes=[];
+           pvb_loc=Location.none;
+          }
+      in
+      pp f "@[<2>method%s %a%a@]%a"
+        (override ovf)
+        private_flag pf
+        (fun f e -> match e.pexp_desc with
+           | Pexp_poly (e, Some ct) ->
+               pp f "%s :@;%a=@;%a"
+                 s.txt (core_type ctxt) ct (expression ctxt) e
+           | Pexp_poly (e,None) -> bind e
+           | _ -> bind e) e
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_constraint (ct1, ct2) ->
+      pp f "@[<2>constraint %a =@;%a@]%a"
+        (core_type ctxt) ct1
+        (core_type ctxt) ct2
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_initializer (e) ->
+      pp f "@[<2>initializer@ %a@]%a"
+        (expression ctxt) e
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_attribute a -> floating_attribute ctxt f a
+  | Pcf_extension e ->
+      item_extension ctxt f e;
+      item_attributes ctxt f x.pcf_attributes
+
+and class_structure ctxt f { pcstr_self = p; pcstr_fields =  l } =
+  pp f "@[@[object%a@;%a@]@;end@]"
+    (fun f p -> match p.ppat_desc with
+       | Ppat_any -> ()
+       | Ppat_constraint _ -> pp f " %a" (pattern ctxt) p
+       | _ -> pp f " (%a)" (pattern ctxt) p) p
+    (list (class_field ctxt)) l
+
+and class_expr ctxt f x =
+  if x.pcl_attributes <> [] then begin
+    pp f "((%a)%a)" (class_expr ctxt) {x with pcl_attributes=[]}
+      (attributes ctxt) x.pcl_attributes
+  end else
     match x.pcl_desc with
-    | Pcl_structure (cs) -> self#class_structure f cs
+    | Pcl_structure (cs) -> class_structure ctxt f cs
     | Pcl_fun (l, eo, p, e) ->
         pp f "fun@ %a@ ->@ %a"
-          self#label_exp (l,eo,p)
-          self#class_expr e
+          (label_exp ctxt) (l,eo,p)
+          (class_expr ctxt) e
     | Pcl_let (rf, l, ce) ->
         pp f "%a@ in@ %a"
-          self#bindings  (rf,l)
-          self#class_expr ce
+          (bindings ctxt) (rf,l)
+          (class_expr ctxt) ce
     | Pcl_apply (ce, l) ->
-        pp f "(%a@ %a)"
-          self#class_expr ce
-          (self#list self#label_x_expression_param) l
+        pp f "((%a)@ %a)" (* Cf: #7200 *)
+          (class_expr ctxt) ce
+          (list (label_x_expression_param ctxt)) l
     | Pcl_constr (li, l) ->
         pp f "%a%a"
           (fun f l-> if l <>[] then
-            pp f "[%a]@ "
-              (self#list self#core_type  ~sep:"," ) l ) l
-          self#longident_loc li
+              pp f "[%a]@ "
+                (list (core_type ctxt) ~sep:",") l) l
+          longident_loc li
     | Pcl_constraint (ce, ct) ->
         pp f "(%a@ :@ %a)"
-          self#class_expr ce
-          self#class_type ct
-    | Pcl_extension e -> self#extension f e
-
-  method module_type f x =
-    if x.pmty_attributes <> [] then begin
-      pp f "((%a)%a)" self#module_type {x with pmty_attributes=[]}
-        self#attributes x.pmty_attributes
-    end else
+          (class_expr ctxt) ce
+          (class_type ctxt) ct
+    | Pcl_extension e -> extension ctxt f e
+
+and module_type ctxt f x =
+  if x.pmty_attributes <> [] then begin
+    pp f "((%a)%a)" (module_type ctxt) {x with pmty_attributes=[]}
+      (attributes ctxt) x.pmty_attributes
+  end else
     match x.pmty_desc with
     | Pmty_ident li ->
-        pp f "%a" self#longident_loc li;
+        pp f "%a" longident_loc li;
     | Pmty_alias li ->
-        pp f "(module %a)" self#longident_loc li;
+        pp f "(module %a)" longident_loc li;
     | Pmty_signature (s) ->
         pp f "@[@[sig@ %a@]@ end@]" (* "@[sig@ %a@ end@]" *)
-          (self#list self#signature_item  ) s (* FIXME wrong indentation*)
+          (list (signature_item ctxt)) s (* FIXME wrong indentation*)
     | Pmty_functor (_, None, mt2) ->
-        pp f "@[functor () ->@ %a@]" self#module_type mt2
+        pp f "@[functor () ->@ %a@]" (module_type ctxt) mt2
     | Pmty_functor (s, Some mt1, mt2) ->
         if s.txt = "_" then
           pp f "@[%a@ ->@ %a@]"
-             self#module_type mt1  self#module_type mt2
+            (module_type ctxt) mt1 (module_type ctxt) mt2
         else
           pp f "@[functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt
-             self#module_type mt1  self#module_type mt2
+            (module_type ctxt) mt1 (module_type ctxt) mt2
     | Pmty_with (mt, l) ->
         let with_constraint f = function
           | Pwith_type (li, ({ptype_params= ls ;_} as td)) ->
               let ls = List.map fst ls in
               pp f "type@ %a %a =@ %a"
-                (self#list self#core_type ~sep:"," ~first:"(" ~last:")")
-                ls self#longident_loc li  self#type_declaration td
+                (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")")
+                ls longident_loc li (type_declaration ctxt) td
           | Pwith_module (li, li2) ->
-              pp f "module %a =@ %a" self#longident_loc li self#longident_loc
-                 li2;
+              pp f "module %a =@ %a" longident_loc li longident_loc li2;
           | Pwith_typesubst ({ptype_params=ls;_} as td) ->
               let ls = List.map fst ls in
               pp f "type@ %a %s :=@ %a"
-                (self#list self#core_type ~sep:"," ~first:"(" ~last:")")
+                (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")")
                 ls td.ptype_name.txt
-                self#type_declaration  td
+                (type_declaration ctxt) td
           | Pwith_modsubst (s, li2) ->
-              pp f "module %s :=@ %a" s.txt self#longident_loc li2 in
+              pp f "module %s :=@ %a" s.txt longident_loc li2 in
         (match l with
-        | [] -> pp f "@[%a@]" self#module_type mt
-        | _ -> pp f "@[(%a@ with@ %a)@]"
-              self#module_type mt (self#list with_constraint ~sep:"@ and@ ") l )
+         | [] -> pp f "@[%a@]" (module_type ctxt) mt
+         | _ -> pp f "@[(%a@ with@ %a)@]"
+                  (module_type ctxt) mt (list with_constraint ~sep:"@ and@ ") l)
     | Pmty_typeof me ->
-        pp f "@[module@ type@ of@ %a@]"
-          self#module_expr me
-    | Pmty_extension e -> self#extension f e
-
-  method signature f x =  self#list ~sep:"@\n" self#signature_item f x
-
-  method signature_item f x :unit= begin
-    match x.psig_desc with
-    | Psig_type (rf, l) ->
-        self#type_def_list f (rf, l)
-    | Psig_value vd ->
-        let intro = if vd.pval_prim = [] then "val" else "external" in
-          pp f "@[<2>%s@ %a@ :@ %a@]%a" intro
-             protect_ident vd.pval_name.txt
-             self#value_description vd
-             self#item_attributes vd.pval_attributes
-    | Psig_typext te ->
-        self#type_extension f te
-    | Psig_exception ed ->
-        self#exception_declaration f ed
-    | Psig_class l ->
-        let class_description kwd f ({pci_params=ls;pci_name={txt;_};_} as x) =
-          pp f "@[<2>%s %a%a%s@;:@;%a@]%a" kwd
-            self#virtual_flag x.pci_virt
-            self#class_params_def ls txt
-            self#class_type x.pci_expr
-            self#item_attributes x.pci_attributes
-        in begin
-          match l with
-          | [] -> ()
-          | [x] -> class_description "class" f x
-          | x :: xs ->
-              pp f "@[%a@,%a@]"
-                 (class_description "class") x
-                 (self#list ~sep:"@," (class_description "and")) xs
-        end
-    | Psig_module ({pmd_type={pmty_desc=Pmty_alias alias};_} as pmd) ->
-        pp f "@[module@ %s@ =@ %a@]%a" pmd.pmd_name.txt
-          self#longident_loc alias
-          self#item_attributes pmd.pmd_attributes
-    | Psig_module pmd ->
-        pp f "@[module@ %s@ :@ %a@]%a"
-          pmd.pmd_name.txt
-          self#module_type pmd.pmd_type
-          self#item_attributes pmd.pmd_attributes
-    | Psig_open od ->
-        pp f "@[open%s@ %a@]%a"
-           (override od.popen_override)
-           self#longident_loc od.popen_lid
-           self#item_attributes od.popen_attributes
-    | Psig_include incl ->
-        pp f "@[include@ %a@]%a"
-          self#module_type incl.pincl_mod
-          self#item_attributes incl.pincl_attributes
-    | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} ->
-        pp f "@[module@ type@ %s%a@]%a"
-          s.txt
-          (fun f md -> match md with
-          | None -> ()
-          | Some mt ->
-              pp_print_space f () ;
-              pp f "@ =@ %a"  self#module_type mt
-          ) md
-          self#item_attributes attrs
-    | Psig_class_type (l) ->
-        self#class_type_declaration_list f l ;
-    | Psig_recmodule decls ->
-        let rec  string_x_module_type_list f ?(first=true) l =
-          match l with
-          | [] -> () ;
-          | pmd :: tl ->
-              if not first then
-                pp f "@ @[and@ %s:@ %a@]%a" pmd.pmd_name.txt
-                  self#module_type pmd.pmd_type
-                  self#item_attributes pmd.pmd_attributes
-              else
-                pp f "@[module@ rec@ %s:@ %a@]%a" pmd.pmd_name.txt
-                  self#module_type pmd.pmd_type
-                  self#item_attributes pmd.pmd_attributes;
-              string_x_module_type_list f ~first:false tl
-        in
-          string_x_module_type_list f decls
-    | Psig_attribute a -> self#floating_attribute f a
-    | Psig_extension(e, a) ->
-        self#item_extension f e;
-        self#item_attributes f a
-  end
-  method module_expr f x =
-    if x.pmod_attributes <> [] then begin
-      pp f "((%a)%a)" self#module_expr {x with pmod_attributes=[]}
-        self#attributes x.pmod_attributes
-    end else
-    match x.pmod_desc with
+        pp f "@[module@ type@ of@ %a@]" (module_expr ctxt) me
+    | Pmty_extension e -> extension ctxt f e
+
+and signature ctxt f x =  list ~sep:"@\n" (signature_item ctxt) f x
+
+and signature_item ctxt f x : unit =
+  match x.psig_desc with
+  | Psig_type (rf, l) ->
+      type_def_list ctxt f (rf, l)
+  | Psig_value vd ->
+      let intro = if vd.pval_prim = [] then "val" else "external" in
+      pp f "@[<2>%s@ %a@ :@ %a@]%a" intro
+        protect_ident vd.pval_name.txt
+        (value_description ctxt) vd
+        (item_attributes ctxt) vd.pval_attributes
+  | Psig_typext te ->
+      type_extension ctxt f te
+  | Psig_exception ed ->
+      exception_declaration ctxt f ed
+  | Psig_class l ->
+      let class_description kwd f ({pci_params=ls;pci_name={txt;_};_} as x) =
+        pp f "@[<2>%s %a%a%s@;:@;%a@]%a" kwd
+          virtual_flag x.pci_virt
+          (class_params_def ctxt) ls txt
+          (class_type ctxt) x.pci_expr
+          (item_attributes ctxt) x.pci_attributes
+      in begin
+        match l with
+        | [] -> ()
+        | [x] -> class_description "class" f x
+        | x :: xs ->
+            pp f "@[%a@,%a@]"
+              (class_description "class") x
+              (list ~sep:"@," (class_description "and")) xs
+      end
+  | Psig_module ({pmd_type={pmty_desc=Pmty_alias alias};_} as pmd) ->
+      pp f "@[module@ %s@ =@ %a@]%a" pmd.pmd_name.txt
+        longident_loc alias
+        (item_attributes ctxt) pmd.pmd_attributes
+  | Psig_module pmd ->
+      pp f "@[module@ %s@ :@ %a@]%a"
+        pmd.pmd_name.txt
+        (module_type ctxt) pmd.pmd_type
+        (item_attributes ctxt) pmd.pmd_attributes
+  | Psig_open od ->
+      pp f "@[open%s@ %a@]%a"
+        (override od.popen_override)
+        longident_loc od.popen_lid
+        (item_attributes ctxt) od.popen_attributes
+  | Psig_include incl ->
+      pp f "@[include@ %a@]%a"
+        (module_type ctxt) incl.pincl_mod
+        (item_attributes ctxt) incl.pincl_attributes
+  | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} ->
+      pp f "@[module@ type@ %s%a@]%a"
+        s.txt
+        (fun f md -> match md with
+           | None -> ()
+           | Some mt ->
+               pp_print_space f () ;
+               pp f "@ =@ %a" (module_type ctxt) mt
+        ) md
+        (item_attributes ctxt) attrs
+  | Psig_class_type (l) -> class_type_declaration_list ctxt f l
+  | Psig_recmodule decls ->
+      let rec  string_x_module_type_list f ?(first=true) l =
+        match l with
+        | [] -> () ;
+        | pmd :: tl ->
+            if not first then
+              pp f "@ @[and@ %s:@ %a@]%a" pmd.pmd_name.txt
+                (module_type ctxt) pmd.pmd_type
+                (item_attributes ctxt) pmd.pmd_attributes
+            else
+              pp f "@[module@ rec@ %s:@ %a@]%a" pmd.pmd_name.txt
+                (module_type ctxt) pmd.pmd_type
+                (item_attributes ctxt) pmd.pmd_attributes;
+            string_x_module_type_list f ~first:false tl
+      in
+      string_x_module_type_list f decls
+  | Psig_attribute a -> floating_attribute ctxt f a
+  | Psig_extension(e, a) ->
+      item_extension ctxt f e;
+      item_attributes ctxt f a
+
+and module_expr ctxt f x =
+  if x.pmod_attributes <> [] then
+    pp f "((%a)%a)" (module_expr ctxt) {x with pmod_attributes=[]}
+      (attributes ctxt) x.pmod_attributes
+  else match x.pmod_desc with
     | Pmod_structure (s) ->
         pp f "@[struct@;@[<0>%a@]@;<1 -2>end@]"
-          (self#list self#structure_item  ~sep:"@\n") s;
+          (list (structure_item ctxt) ~sep:"@\n") s;
     | Pmod_constraint (me, mt) ->
         pp f "@[(%a@ :@ %a)@]"
-          self#module_expr  me
-          self#module_type mt
+          (module_expr ctxt) me
+          (module_type ctxt) mt
     | Pmod_ident (li) ->
-        pp f "%a" self#longident_loc li;
+        pp f "%a" longident_loc li;
     | Pmod_functor (_, None, me) ->
-        pp f "functor ()@;->@;%a" self#module_expr me
+        pp f "functor ()@;->@;%a" (module_expr ctxt) me
     | Pmod_functor (s, Some mt, me) ->
         pp f "functor@ (%s@ :@ %a)@;->@;%a"
-          s.txt  self#module_type mt  self#module_expr me
+          s.txt (module_type ctxt) mt (module_expr ctxt) me
     | Pmod_apply (me1, me2) ->
-        pp f "%a(%a)" self#module_expr me1  self#module_expr  me2
+        pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2
+        (* Cf: #7200 *)
     | Pmod_unpack e ->
-        pp f "(val@ %a)"  self#expression  e
-    | Pmod_extension e -> self#extension f e
-
-  method structure f x = self#list ~sep:"@\n" self#structure_item f x
-
-  method payload f = function
-    | PStr [{pstr_desc = Pstr_eval (e, attrs)}] ->
-        pp f "@[<2>%a@]%a"
-          self#expression e
-          self#item_attributes attrs
-    | PStr x -> self#structure f x
-    | PTyp x -> pp f ":"; self#core_type f x
-    | PSig x -> pp f ":"; self#signature f x
-    | PPat (x, None) -> pp f "?"; self#pattern f x
-    | PPat (x, Some e) ->
-      pp f "?"; self#pattern f x;
-      pp f " when "; self#expression f e
-
-  (* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *)
-  method binding f {pvb_pat=p; pvb_expr=x; _} =
-    (* .pvb_attributes have already been printed by the caller, #bindings *)
-    let rec pp_print_pexp_function f x =
-      if x.pexp_attributes <> [] then pp f "=@;%a" self#expression x
-      else match x.pexp_desc with
+        pp f "(val@ %a)" (expression ctxt) e
+    | Pmod_extension e -> extension ctxt f e
+
+and structure ctxt f x = list ~sep:"@\n" (structure_item ctxt) f x
+
+and payload ctxt f = function
+  | PStr [{pstr_desc = Pstr_eval (e, attrs)}] ->
+      pp f "@[<2>%a@]%a"
+        (expression ctxt) e
+        (item_attributes ctxt) attrs
+  | PStr x -> structure ctxt f x
+  | PTyp x -> pp f ":"; core_type ctxt f x
+  | PSig x -> pp f ":"; signature ctxt f x
+  | PPat (x, None) -> pp f "?"; pattern ctxt f x
+  | PPat (x, Some e) ->
+      pp f "?"; pattern ctxt f x;
+      pp f " when "; expression ctxt f e
+
+(* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *)
+and binding ctxt f {pvb_pat=p; pvb_expr=x; _} =
+  (* .pvb_attributes have already been printed by the caller, #bindings *)
+  let rec pp_print_pexp_function f x =
+    if x.pexp_attributes <> [] then pp f "=@;%a" (expression ctxt) x
+    else match x.pexp_desc with
       | Pexp_fun (label, eo, p, e) ->
           if label=Nolabel then
-            pp f "%a@ %a" self#simple_pattern p pp_print_pexp_function e
+            pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function e
           else
-            pp f "%a@ %a" self#label_exp (label,eo,p) pp_print_pexp_function e
+            pp f "%a@ %a"
+              (label_exp ctxt) (label,eo,p) pp_print_pexp_function e
       | Pexp_newtype (str,e) ->
           pp f "(type@ %s)@ %a" str pp_print_pexp_function e
-      | _ -> pp f "=@;%a" self#expression x in
-    if x.pexp_attributes <> [] then
-      pp f "%a@;=@;%a" self#pattern p self#expression x
-    else match (x.pexp_desc,p.ppat_desc) with
+      | _ -> pp f "=@;%a" (expression ctxt) x
+  in
+  if x.pexp_attributes <> []
+  then pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x
+  else match (x.pexp_desc,p.ppat_desc) with
     | ( _ , Ppat_constraint( p ,ty)) -> (* special case for the first*)
-        (match ty.ptyp_desc with
+        begin match ty.ptyp_desc with
         | Ptyp_poly _ ->
-            pp f "%a@;:@;%a@;=@;%a" self#simple_pattern p
-              self#core_type ty self#expression x
+            pp f "%a@;:@;%a@;=@;%a" (simple_pattern ctxt) p
+              (core_type ctxt) ty (expression ctxt) x
         | _ ->
-            pp f "(%a@;:@;%a)@;=@;%a" self#simple_pattern p
-              self#core_type ty self#expression x)
+            pp f "(%a@;:@;%a)@;=@;%a" (simple_pattern ctxt) p
+              (core_type ctxt) ty (expression ctxt) x
+        end
     | Pexp_constraint (e,t1),Ppat_var {txt;_} ->
-        pp f "%a@;:@ %a@;=@;%a" protect_ident txt self#core_type t1
-           self#expression e
+      pp f "%a@;:@ %a@;=@;%a" protect_ident txt
+        (core_type ctxt) t1 (expression ctxt) e
     | (_, Ppat_var _) ->
-        pp f "%a@ %a" self#simple_pattern p pp_print_pexp_function x
+        pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x
     | _ ->
-        pp f "%a@;=@;%a" self#pattern p self#expression x
-  (* [in] is not printed *)
-  method bindings f (rf,l) =
-    let binding kwd rf f x =
-      pp f "@[<2>%s %a%a@]@ %a" kwd self#rec_flag rf
-         self#binding x self#item_attributes x.pvb_attributes
-    in
-    begin match l with
-    | [] -> ()
-    | [x] -> binding "let" rf f x
-    | x::xs ->
-        pp f "@[%a@,%a@]"
-          (binding "let" rf) x
-          (self#list ~sep:"@," (binding "and" Nonrecursive)) xs
-    end
-
-  method structure_item f x = begin
-    match x.pstr_desc with
-    | Pstr_eval (e, attrs) ->
-        pp f "@[;;%a@]%a"
-          self#expression e
-          self#item_attributes attrs
-    | Pstr_type (_, []) -> assert false
-    | Pstr_type (rf, l)  -> self#type_def_list f (rf, l)
-    | Pstr_value (rf, l) ->
-        (* pp f "@[let %a%a@]"  self#rec_flag rf self#bindings l *)
-        pp f "@[<2>%a@]" self#bindings (rf,l)
-    | Pstr_typext te -> self#type_extension f te
-    | Pstr_exception ed -> self#exception_declaration f ed
-    | Pstr_module x ->
-        let rec module_helper me =
-          match me.pmod_desc with
-          | Pmod_functor(s,mt,me') when me.pmod_attributes = [] ->
-              if mt = None then pp f "()"
-              else Misc.may (pp f "(%s:%a)" s.txt self#module_type) mt;
-              module_helper me'
-          | _ -> me
-        in
-        pp f "@[module %s%a@]%a"
-          x.pmb_name.txt
-          (fun f me ->
-            let me = module_helper me in
-            (match me.pmod_desc with
-            | Pmod_constraint
-                (me',
-                 ({pmty_desc=(Pmty_ident (_)
-                             | Pmty_signature (_));_} as mt))
-              when me.pmod_attributes = [] ->
-                pp f " :@;%a@;=@;%a@;" self#module_type mt self#module_expr me'
-            | _ ->
-                pp f " =@ %a"  self#module_expr  me
-            )) x.pmb_expr
-          self#item_attributes x.pmb_attributes
-    | Pstr_open od ->
-        pp f "@[<2>open%s@;%a@]%a"
-           (override od.popen_override)
-           self#longident_loc od.popen_lid
-           self#item_attributes od.popen_attributes
-    | Pstr_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} ->
-        pp f "@[module@ type@ %s%a@]%a"
-          s.txt
-          (fun f md -> match md with
-          | None -> ()
-          | Some mt ->
-              pp_print_space f () ;
-              pp f "@ =@ %a"  self#module_type mt
-          ) md
-          self#item_attributes attrs
-    | Pstr_class l ->
-        let extract_class_args cl =
-          let rec loop acc cl =
-            match cl.pcl_desc with
-            | Pcl_fun (l, eo, p, cl') when cl.pcl_attributes = [] ->
-                loop ((l,eo,p) :: acc) cl'
-            | _ -> List.rev acc, cl
-          in
-          let args, cl = loop [] cl in
-          let constr, cl =
-            match cl.pcl_desc with
-            | Pcl_constraint (cl', ct) when cl.pcl_attributes = [] ->
-                Some ct, cl'
-            | _ -> None, cl
-          in
-            args, constr, cl
+        pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x
+
+(* [in] is not printed *)
+and bindings ctxt f (rf,l) =
+  let binding kwd rf f x =
+    pp f "@[<2>%s %a%a@]@ %a" kwd rec_flag rf
+      (binding ctxt) x (item_attributes ctxt) x.pvb_attributes
+  in
+  match l with
+  | [] -> ()
+  | [x] -> binding "let" rf f x
+  | x::xs ->
+      pp f "@[%a@,%a@]"
+        (binding "let" rf) x
+        (list ~sep:"@," (binding "and" Nonrecursive)) xs
+
+and structure_item ctxt f x =
+  match x.pstr_desc with
+  | Pstr_eval (e, attrs) ->
+      pp f "@[;;%a@]%a"
+        (expression ctxt) e
+        (item_attributes ctxt) attrs
+  | Pstr_type (_, []) -> assert false
+  | Pstr_type (rf, l)  -> type_def_list ctxt f (rf, l)
+  | Pstr_value (rf, l) ->
+      (* pp f "@[let %a%a@]"  rec_flag rf bindings l *)
+      pp f "@[<2>%a@]" (bindings ctxt) (rf,l)
+  | Pstr_typext te -> type_extension ctxt f te
+  | Pstr_exception ed -> exception_declaration ctxt f ed
+  | Pstr_module x ->
+      let rec module_helper me =
+        match me.pmod_desc with
+        | Pmod_functor(s,mt,me') when me.pmod_attributes = [] ->
+            if mt = None then pp f "()"
+            else Misc.may (pp f "(%s:%a)" s.txt (module_type ctxt)) mt;
+            module_helper me'
+        | _ -> me
+      in
+      pp f "@[module %s%a@]%a"
+        x.pmb_name.txt
+        (fun f me ->
+           let me = module_helper me in
+           match me.pmod_desc with
+           | Pmod_constraint
+               (me',
+                ({pmty_desc=(Pmty_ident (_)
+                            | Pmty_signature (_));_} as mt))
+             when me.pmod_attributes = [] ->
+               pp f " :@;%a@;=@;%a@;"
+                 (module_type ctxt) mt (module_expr ctxt) me'
+           | _ -> pp f " =@ %a" (module_expr ctxt) me
+        ) x.pmb_expr
+        (item_attributes ctxt) x.pmb_attributes
+  | Pstr_open od ->
+      pp f "@[<2>open%s@;%a@]%a"
+        (override od.popen_override)
+        longident_loc od.popen_lid
+        (item_attributes ctxt) od.popen_attributes
+  | Pstr_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} ->
+      pp f "@[module@ type@ %s%a@]%a"
+        s.txt
+        (fun f md -> match md with
+           | None -> ()
+           | Some mt ->
+               pp_print_space f () ;
+               pp f "@ =@ %a" (module_type ctxt) mt
+        ) md
+        (item_attributes ctxt) attrs
+  | Pstr_class l ->
+      let extract_class_args cl =
+        let rec loop acc cl =
+          match cl.pcl_desc with
+          | Pcl_fun (l, eo, p, cl') when cl.pcl_attributes = [] ->
+              loop ((l,eo,p) :: acc) cl'
+          | _ -> List.rev acc, cl
         in
-        let class_constraint f ct = pp f ": @[%a@] " self#class_type ct in
-        let class_declaration kwd f
-            ({pci_params=ls; pci_name={txt;_}; _} as x) =
-          let args, constr, cl = extract_class_args x.pci_expr in
-          pp f "@[<2>%s %a%a%s %a%a=@;%a@]%a" kwd
-             self#virtual_flag x.pci_virt
-             self#class_params_def ls txt
-             (self#list self#label_exp) args
-             (self#option class_constraint) constr
-             self#class_expr cl
-             self#item_attributes x.pci_attributes
-        in begin
-          match l with
-          | [] -> ()
-          | [x] -> class_declaration "class" f x
-          | x :: xs ->
-              pp f "@[%a@,%a@]"
-                 (class_declaration "class") x
-                 (self#list ~sep:"@," (class_declaration "and")) xs
-        end
-    | Pstr_class_type (l) ->
-        self#class_type_declaration_list f l ;
-    | Pstr_primitive vd ->
-        pp f "@[external@ %a@ :@ %a@]%a"
-          protect_ident vd.pval_name.txt
-          self#value_description vd
-          self#item_attributes vd.pval_attributes
-    | Pstr_include incl ->
-        pp f "@[include@ %a@]%a"
-          self#module_expr incl.pincl_mod
-          self#item_attributes incl.pincl_attributes
-    | Pstr_recmodule decls -> (* 3.07 *)
-        let aux f = function
-          | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) ->
-              pp f "@[@ and@ %s:%a@ =@ %a@]%a" pmb.pmb_name.txt
-              self#module_type typ
-              self#module_expr expr
-              self#item_attributes pmb.pmb_attributes
-          | _ -> assert false
+        let args, cl = loop [] cl in
+        let constr, cl =
+          match cl.pcl_desc with
+          | Pcl_constraint (cl', ct) when cl.pcl_attributes = [] ->
+              Some ct, cl'
+          | _ -> None, cl
         in
-        begin match decls with
-        | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 ->
-            pp f "@[@[module@ rec@ %s:%a@ =@ %a@]%a@ %a@]"
-              pmb.pmb_name.txt
-              self#module_type typ
-              self#module_expr expr
-              self#item_attributes pmb.pmb_attributes
-              (fun f l2 -> List.iter (aux f) l2) l2
+        args, constr, cl
+      in
+      let class_constraint f ct = pp f ": @[%a@] " (class_type ctxt) ct in
+      let class_declaration kwd f
+          ({pci_params=ls; pci_name={txt;_}; _} as x) =
+        let args, constr, cl = extract_class_args x.pci_expr in
+        pp f "@[<2>%s %a%a%s %a%a=@;%a@]%a" kwd
+          virtual_flag x.pci_virt
+          (class_params_def ctxt) ls txt
+          (list (label_exp ctxt)) args
+          (option class_constraint) constr
+          (class_expr ctxt) cl
+          (item_attributes ctxt) x.pci_attributes
+      in begin
+        match l with
+        | [] -> ()
+        | [x] -> class_declaration "class" f x
+        | x :: xs ->
+            pp f "@[%a@,%a@]"
+              (class_declaration "class") x
+              (list ~sep:"@," (class_declaration "and")) xs
+      end
+  | Pstr_class_type l -> class_type_declaration_list ctxt f l
+  | Pstr_primitive vd ->
+      pp f "@[external@ %a@ :@ %a@]%a"
+        protect_ident vd.pval_name.txt
+        (value_description ctxt) vd
+        (item_attributes ctxt) vd.pval_attributes
+  | Pstr_include incl ->
+      pp f "@[include@ %a@]%a"
+        (module_expr ctxt) incl.pincl_mod
+        (item_attributes ctxt) incl.pincl_attributes
+  | Pstr_recmodule decls -> (* 3.07 *)
+      let aux f = function
+        | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) ->
+            pp f "@[@ and@ %s:%a@ =@ %a@]%a" pmb.pmb_name.txt
+              (module_type ctxt) typ
+              (module_expr ctxt) expr
+              (item_attributes ctxt) pmb.pmb_attributes
         | _ -> assert false
-        end
-    | Pstr_attribute a -> self#floating_attribute f a
-    | Pstr_extension(e, a) ->
-        self#item_extension f e;
-        self#item_attributes f a
-  end
-  method type_param f (ct, a) =
-    pp f "%s%a" (type_variance a) self#core_type ct
-  method type_params f = function
-    [] -> ()
-  | l -> pp f "%a " (self#list self#type_param ~first:"(" ~last:")" ~sep:",") l
-  method  type_def_list f (rf, l) =
-    let type_decl kwd rf f x =
-      let eq =
-        if (x.ptype_kind = Ptype_abstract)
-           && (x.ptype_manifest = None) then ""
-        else " ="
       in
-      pp f "@[<2>%s %a%a%s%s%a@]%a" kwd
-        self#nonrec_flag rf
-        self#type_params x.ptype_params
-        x.ptype_name.txt eq
-        self#type_declaration x
-        self#item_attributes x.ptype_attributes
-    in
-    match l with
-    | [] -> assert false
-    | [x] -> type_decl "type" rf f x
-    | x :: xs -> pp f "@[%a@,%a@]"
-          (type_decl "type" rf) x
-          (self#list ~sep:"@," (type_decl "and" Recursive)) xs
-
-  method record_declaration f lbls =
-    let type_record_field f pld =
-      pp f "@[<2>%a%s:@;%a@;%a@]"
-        self#mutable_flag pld.pld_mutable
-        pld.pld_name.txt
-        self#core_type pld.pld_type
-        self#attributes pld.pld_attributes
-    in
-    pp f "{@\n%a}"
-      (self#list type_record_field ~sep:";@\n" )  lbls
-
-  method type_declaration f x =
-    (* type_declaration has an attribute field,
-       but it's been printed by the caller of this method *)
-    let priv f =
-      match x.ptype_private with
-        Public -> ()
-      | Private -> pp f "@;private"
+      begin match decls with
+      | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 ->
+          pp f "@[@[module@ rec@ %s:%a@ =@ %a@]%a@ %a@]"
+            pmb.pmb_name.txt
+            (module_type ctxt) typ
+            (module_expr ctxt) expr
+            (item_attributes ctxt) pmb.pmb_attributes
+            (fun f l2 -> List.iter (aux f) l2) l2
+      | _ -> assert false
+      end
+  | Pstr_attribute a -> floating_attribute ctxt f a
+  | Pstr_extension(e, a) ->
+      item_extension ctxt f e;
+      item_attributes ctxt f a
+
+and type_param ctxt f (ct, a) =
+  pp f "%s%a" (type_variance a) (core_type ctxt) ct
+
+and type_params ctxt f = function
+  | [] -> ()
+  | l -> pp f "%a " (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",") l
+
+and type_def_list ctxt f (rf, l) =
+  let type_decl kwd rf f x =
+    let eq =
+      if (x.ptype_kind = Ptype_abstract)
+         && (x.ptype_manifest = None) then ""
+      else " ="
     in
-    let manifest f =
-      match x.ptype_manifest with
-      | None -> ()
-      | Some y ->
+    pp f "@[<2>%s %a%a%s%s%a@]%a" kwd
+      nonrec_flag rf
+      (type_params ctxt) x.ptype_params
+      x.ptype_name.txt eq
+      (type_declaration ctxt) x
+      (item_attributes ctxt) x.ptype_attributes
+  in
+  match l with
+  | [] -> assert false
+  | [x] -> type_decl "type" rf f x
+  | x :: xs -> pp f "@[%a@,%a@]"
+                 (type_decl "type" rf) x
+                 (list ~sep:"@," (type_decl "and" Recursive)) xs
+
+and record_declaration ctxt f lbls =
+  let type_record_field f pld =
+    pp f "@[<2>%a%s:@;%a@;%a@]"
+      mutable_flag pld.pld_mutable
+      pld.pld_name.txt
+      (core_type ctxt) pld.pld_type
+      (attributes ctxt) pld.pld_attributes
+  in
+  pp f "{@\n%a}"
+    (list type_record_field ~sep:";@\n" )  lbls
+
+and type_declaration ctxt f x =
+  (* type_declaration has an attribute field,
+     but it's been printed by the caller of this method *)
+  let priv f =
+    match x.ptype_private with
+    | Public -> ()
+    | Private -> pp f "@;private"
+  in
+  let manifest f =
+    match x.ptype_manifest with
+    | None -> ()
+    | Some y ->
         if x.ptype_kind = Ptype_abstract then
-          pp f "%t@;%a" priv self#core_type y
+          pp f "%t@;%a" priv (core_type ctxt) y
         else
-          pp f "@;%a" self#core_type y
-    in
-    let constructor_declaration f pcd =
-      pp f "|@;";
-      self#constructor_declaration f (pcd.pcd_name.txt, pcd.pcd_args,
-                                      pcd.pcd_res, pcd.pcd_attributes)
-    in
-    let repr f =
-      let intro f =
-        if x.ptype_manifest = None then ()
-        else pp f "@;="
-      in
-      match x.ptype_kind with
-      | Ptype_variant xs ->
-          pp f "%t%t@\n%a" intro priv
-             (self#list ~sep:"@\n" constructor_declaration) xs
-      | Ptype_abstract -> ()
-      | Ptype_record l ->
-          pp f "%t%t@;%a" intro priv self#record_declaration l
-      | Ptype_open -> pp f "%t%t@;.." intro priv
-    in
-    let constraints f =
-      List.iter
-        (fun (ct1,ct2,_) ->
-           pp f "@[@ constraint@ %a@ =@ %a@]"
-              self#core_type ct1 self#core_type ct2)
-        x.ptype_cstrs
+          pp f "@;%a" (core_type ctxt) y
+  in
+  let constructor_declaration f pcd =
+    pp f "|@;";
+    constructor_declaration ctxt f
+      (pcd.pcd_name.txt, pcd.pcd_args, pcd.pcd_res, pcd.pcd_attributes)
+  in
+  let repr f =
+    let intro f =
+      if x.ptype_manifest = None then ()
+      else pp f "@;="
     in
-      pp f "%t%t%t" manifest repr constraints
-
-  method type_extension f x =
-    let extension_constructor f x =
-      pp f "@\n|@;%a" self#extension_constructor x
-    in
-      pp f "@[<2>type %a%a +=%a@]%a"
-         (fun f -> function
-                | [] -> ()
-                | l ->  pp f "%a@;" (self#list self#type_param ~first:"("
-                                               ~last:")" ~sep:",")
-                                    l)
-         x.ptyext_params
-         self#longident_loc x.ptyext_path
-         (self#list ~sep:"" extension_constructor)
-         x.ptyext_constructors
-         self#item_attributes x.ptyext_attributes
-
-  method constructor_declaration f (name, args, res, attrs) =
-    match res with
-    | None ->
-        pp f "%s%a@;%a" name
-          (fun f -> function
-             | Pcstr_tuple [] -> ()
-             | Pcstr_tuple l ->
-                 pp f "@;of@;%a" (self#list self#core_type1 ~sep:"*@;") l
-             | Pcstr_record l -> pp f "@;of@;%a" (self#record_declaration) l
-          ) args
-          self#attributes attrs
-    | Some r ->
-        pp f "%s:@;%a@;%a" name
-          (fun f -> function
-             | Pcstr_tuple [] -> self#core_type1 f r
-             | Pcstr_tuple l -> pp f "%a@;->@;%a"
-                                  (self#list self#core_type1 ~sep:"*@;") l
-                                  self#core_type1 r
-             | Pcstr_record l ->
-                 pp f "%a@;->@;%a" (self#record_declaration) l self#core_type1 r
-          )
-          args
-          self#attributes attrs
-
-
-  method extension_constructor f x =
-    match x.pext_kind with
-    | Pext_decl(l, r) ->
-        self#constructor_declaration f (x.pext_name.txt, l, r,
-                                        x.pext_attributes)
-    | Pext_rebind li ->
-        pp f "%s%a@;=@;%a" x.pext_name.txt
-          self#attributes x.pext_attributes
-          self#longident_loc li
-
-  method case_list f l : unit =
-    let aux f {pc_lhs; pc_guard; pc_rhs} =
-      pp f "@;| @[<2>%a%a@;->@;%a@]"
-        self#pattern pc_lhs (self#option self#expression ~first:"@;when@;")
-        pc_guard self#under_pipe#expression pc_rhs
-    in
-    self#list aux f l ~sep:""
-  method label_x_expression_param f (l,e) =
-    let simple_name = match e.pexp_desc with
+    match x.ptype_kind with
+    | Ptype_variant xs ->
+        pp f "%t%t@\n%a" intro priv
+          (list ~sep:"@\n" constructor_declaration) xs
+    | Ptype_abstract -> ()
+    | Ptype_record l ->
+        pp f "%t%t@;%a" intro priv (record_declaration ctxt) l
+    | Ptype_open -> pp f "%t%t@;.." intro priv
+  in
+  let constraints f =
+    List.iter
+      (fun (ct1,ct2,_) ->
+         pp f "@[@ constraint@ %a@ =@ %a@]"
+           (core_type ctxt) ct1 (core_type ctxt) ct2)
+      x.ptype_cstrs
+  in
+  pp f "%t%t%t" manifest repr constraints
+
+and type_extension ctxt f x =
+  let extension_constructor f x =
+    pp f "@\n|@;%a" (extension_constructor ctxt) x
+  in
+  pp f "@[<2>type %a%a += %a@ %a@]%a"
+    (fun f -> function
+       | [] -> ()
+       | l ->
+           pp f "%a@;" (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",") l)
+    x.ptyext_params
+    longident_loc x.ptyext_path
+    private_flag x.ptyext_private (* Cf: #7200 *)
+    (list ~sep:"" extension_constructor)
+    x.ptyext_constructors
+    (item_attributes ctxt) x.ptyext_attributes
+
+and constructor_declaration ctxt f (name, args, res, attrs) =
+  let name =
+    match name with
+    | "::" -> "(::)"
+    | s -> s in
+  match res with
+  | None ->
+      pp f "%s%a@;%a" name
+        (fun f -> function
+           | Pcstr_tuple [] -> ()
+           | Pcstr_tuple l ->
+             pp f "@;of@;%a" (list (core_type1 ctxt) ~sep:"@;*@;") l
+           | Pcstr_record l -> pp f "@;of@;%a" (record_declaration ctxt) l
+        ) args
+        (attributes ctxt) attrs
+  | Some r ->
+      pp f "%s:@;%a@;%a" name
+        (fun f -> function
+           | Pcstr_tuple [] -> core_type1 ctxt f r
+           | Pcstr_tuple l -> pp f "%a@;->@;%a"
+                                (list (core_type1 ctxt) ~sep:"*@;") l
+                                (core_type1 ctxt) r
+           | Pcstr_record l ->
+               pp f "%a@;->@;%a" (record_declaration ctxt) l (core_type1 ctxt) r
+        )
+        args
+        (attributes ctxt) attrs
+
+and extension_constructor ctxt f x =
+  (* Cf: #7200 *)
+  match x.pext_kind with
+  | Pext_decl(l, r) ->
+      constructor_declaration ctxt f (x.pext_name.txt, l, r, x.pext_attributes)
+  | Pext_rebind li ->
+      pp f "%s%a@;=@;%a" x.pext_name.txt
+        (attributes ctxt) x.pext_attributes
+        longident_loc li
+
+and case_list ctxt f l : unit =
+  let aux f {pc_lhs; pc_guard; pc_rhs} =
+    pp f "@;| @[<2>%a%a@;->@;%a@]"
+      (pattern ctxt) pc_lhs (option (expression ctxt) ~first:"@;when@;")
+      pc_guard (expression (under_pipe ctxt)) pc_rhs
+  in
+  list aux f l ~sep:""
+
+and label_x_expression_param ctxt f (l,e) =
+  let simple_name = match e.pexp_desc with
     | Pexp_ident {txt=Lident l;_} -> Some l
     | _ -> None
-    in match l with
-    | Nolabel  -> self#expression2 f e ; (* level 2*)
-    | Optional str ->
-          if Some str = simple_name then
-            pp f "?%s" str
-          else
-            pp f "?%s:%a" str self#simple_expr e
-    | Labelled lbl ->
-          if Some lbl = simple_name then
-            pp f "~%s" lbl
-          else
-            pp f "~%s:%a" lbl self#simple_expr e
-
-  method directive_argument f x =
-    (match x with
-    | Pdir_none -> ()
-    | Pdir_string (s) -> pp f "@ %S" s
-    | Pdir_int (n,None) -> pp f "@ %s" n
-    | Pdir_int (n,Some m) -> pp f "@ %s%c" n m
-    | Pdir_ident (li) -> pp f "@ %a" self#longident li
-    | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b))
-
-  method toplevel_phrase f x =
-    match x with
-    | Ptop_def (s) ->
-        pp_open_hvbox f 0;
-        self#list self#structure_item f s ;
-        pp_close_box f ();
-    | Ptop_dir (s, da) ->
-        pp f "@[#%s@ %a@]" s self#directive_argument da
-end;;
-
-
-let default = new printer ()
-
+  in match l with
+  | Nolabel  -> expression2 ctxt f e (* level 2*)
+  | Optional str ->
+      if Some str = simple_name then
+        pp f "?%s" str
+      else
+        pp f "?%s:%a" str (simple_expr ctxt) e
+  | Labelled lbl ->
+      if Some lbl = simple_name then
+        pp f "~%s" lbl
+      else
+        pp f "~%s:%a" lbl (simple_expr ctxt) e
+
+and directive_argument f x =
+  match x with
+  | Pdir_none -> ()
+  | Pdir_string (s) -> pp f "@ %S" s
+  | Pdir_int (n, None) -> pp f "@ %s" n
+  | Pdir_int (n, Some m) -> pp f "@ %s%c" n m
+  | Pdir_ident (li) -> pp f "@ %a" longident li
+  | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b)
 
 let toplevel_phrase f x =
   match x with
-  | Ptop_def (s) ->pp f "@[%a@]"  (default#list default#structure_item) s
+  | Ptop_def (s) ->pp f "@[%a@]"  (list (structure_item reset_ctxt)) s
    (* pp_open_hvbox f 0; *)
    (* pp_print_list structure_item f s ; *)
    (* pp_close_box f (); *)
   | Ptop_dir (s, da) ->
-   pp f "@[#%s@ %a@]" s default#directive_argument da
+   pp f "@[#%s@ %a@]" s directive_argument da
    (* pp f "@[#%s@ %a@]" s directive_argument da *)
 
 let expression f x =
-  pp f "@[%a@]" default#expression x
-
+  pp f "@[%a@]" (expression reset_ctxt) x
 
 let string_of_expression x =
   ignore (flush_str_formatter ()) ;
   let f = str_formatter in
-  default#expression f x ;
-  flush_str_formatter () ;;
+  expression f x;
+  flush_str_formatter ()
+
 let string_of_structure x =
   ignore (flush_str_formatter ());
   let f = str_formatter in
-  default#structure f x;
-  flush_str_formatter ();;
+  structure reset_ctxt f x;
+  flush_str_formatter ()
 
 let top_phrase f x =
-  pp_print_newline f () ;
+  pp_print_newline f ();
   toplevel_phrase f x;
-  pp f ";;" ;
-  pp_print_newline f ();;
+  pp f ";;";
+  pp_print_newline f ()
 
-let core_type=default#core_type
-let pattern=default#pattern
-let signature=default#signature
-let structure=default#structure
+let core_type = core_type reset_ctxt
+let pattern = pattern reset_ctxt
+let signature = signature reset_ctxt
+let structure = structure reset_ctxt
diff --git a/parsing/pprintast.mli b/parsing/pprintast.mli
index ec272254..60f57cf4 100644
--- a/parsing/pprintast.mli
+++ b/parsing/pprintast.mli
@@ -14,131 +14,7 @@
 (**************************************************************************)
 
 type space_formatter = (unit, Format.formatter, unit) format
-class printer :
-  unit ->
-  object ('b)
-    val pipe : bool
-    val semi : bool
-    method binding :
-      Format.formatter -> Parsetree.value_binding -> unit
-    method bindings:
-        Format.formatter ->
-          Asttypes.rec_flag * Parsetree.value_binding list ->
-            unit
-    method case_list :
-      Format.formatter -> Parsetree.case list -> unit
-    method class_expr : Format.formatter -> Parsetree.class_expr -> unit
-    method class_field : Format.formatter -> Parsetree.class_field -> unit
-    method class_params_def :
-      Format.formatter -> (Parsetree.core_type * Asttypes.variance) list -> unit
-    method class_signature :
-      Format.formatter -> Parsetree.class_signature -> unit
-    method class_structure :
-      Format.formatter -> Parsetree.class_structure -> unit
-    method class_type : Format.formatter -> Parsetree.class_type -> unit
-    method class_type_declaration_list :
-      Format.formatter -> Parsetree.class_type_declaration list -> unit
-    method constant : Format.formatter -> Parsetree.constant -> unit
-    method constant_string : Format.formatter -> string -> unit
-    method constructor_declaration :
-      Format.formatter -> (string * Parsetree.constructor_arguments
-                           * Parsetree.core_type option * Parsetree.attributes)
-        -> unit
-    method core_type : Format.formatter -> Parsetree.core_type -> unit
-    method core_type1 : Format.formatter -> Parsetree.core_type -> unit
-    method direction_flag :
-      Format.formatter -> Asttypes.direction_flag -> unit
-    method directive_argument :
-      Format.formatter -> Parsetree.directive_argument -> unit
-    method exception_declaration :
-      Format.formatter -> Parsetree.extension_constructor -> unit
-    method expression : Format.formatter -> Parsetree.expression -> unit
-    method expression1 : Format.formatter -> Parsetree.expression -> unit
-    method expression2 : Format.formatter -> Parsetree.expression -> unit
-    method extension_constructor :
-      Format.formatter -> Parsetree.extension_constructor -> unit
-    method label_exp :
-      Format.formatter ->
-      Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern ->
-      unit
-    method label_x_expression_param :
-      Format.formatter -> Asttypes.arg_label * Parsetree.expression -> unit
-    method list :
-      ?sep:space_formatter ->
-      ?first:space_formatter ->
-      ?last:space_formatter ->
-      (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a list -> unit
-    method longident : Format.formatter -> Longident.t -> unit
-    method longident_loc :
-      Format.formatter -> Longident.t Asttypes.loc -> unit
-    method module_expr : Format.formatter -> Parsetree.module_expr -> unit
-    method module_type : Format.formatter -> Parsetree.module_type -> unit
-    method mutable_flag : Format.formatter -> Asttypes.mutable_flag -> unit
-    method option :
-      ?first:space_formatter ->
-      ?last:space_formatter ->
-      (Format.formatter -> 'a -> unit) ->
-      Format.formatter -> 'a option -> unit
-    method paren :
-        ?first:space_formatter -> ?last:space_formatter -> bool ->
-          (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit
-    method pattern : Format.formatter -> Parsetree.pattern -> unit
-    method pattern1 : Format.formatter -> Parsetree.pattern -> unit
-    method payload : Format.formatter -> Parsetree.payload -> unit
-    method private_flag : Format.formatter -> Asttypes.private_flag -> unit
-    method rec_flag : Format.formatter -> Asttypes.rec_flag -> unit
-    method nonrec_flag : Format.formatter -> Asttypes.rec_flag -> unit
-    method record_declaration :
-        Format.formatter -> Parsetree.label_declaration list -> unit
 
-    method reset : 'b
-    method reset_semi : 'b
-    method reset_ifthenelse : 'b
-    method reset_pipe : 'b
-
-    method signature :
-      Format.formatter -> Parsetree.signature_item list -> unit
-    method signature_item :
-      Format.formatter -> Parsetree.signature_item -> unit
-    method simple_expr : Format.formatter -> Parsetree.expression -> unit
-    method simple_pattern : Format.formatter -> Parsetree.pattern -> unit
-    method string_quot : Format.formatter -> Asttypes.label -> unit
-    method structure :
-      Format.formatter -> Parsetree.structure_item list -> unit
-    method structure_item :
-      Format.formatter -> Parsetree.structure_item -> unit
-    method sugar_expr : Format.formatter -> Parsetree.expression -> bool
-    method toplevel_phrase :
-      Format.formatter -> Parsetree.toplevel_phrase -> unit
-    method type_declaration :
-      Format.formatter -> Parsetree.type_declaration -> unit
-    method type_def_list :
-      Format.formatter -> Asttypes.rec_flag * Parsetree.type_declaration list
-        -> unit
-    method type_extension :
-      Format.formatter -> Parsetree.type_extension -> unit
-    method type_param :
-      Format.formatter -> Parsetree.core_type * Asttypes.variance -> unit
-    method type_params :
-      Format.formatter -> (Parsetree.core_type * Asttypes.variance) list -> unit
-    method type_with_label :
-      Format.formatter -> Asttypes.arg_label * Parsetree.core_type -> unit
-    method tyvar : Format.formatter -> string -> unit
-    method under_pipe : 'b
-    method under_semi : 'b
-    method under_ifthenelse : 'b
-    method value_description :
-      Format.formatter -> Parsetree.value_description -> unit
-    method virtual_flag : Format.formatter -> Asttypes.virtual_flag -> unit
-    method attribute : Format.formatter -> Parsetree.attribute -> unit
-    method item_attribute : Format.formatter -> Parsetree.attribute -> unit
-    method floating_attribute : Format.formatter -> Parsetree.attribute -> unit
-    method attributes : Format.formatter -> Parsetree.attributes -> unit
-    method item_attributes : Format.formatter -> Parsetree.attributes -> unit
-    method extension : Format.formatter -> Parsetree.extension -> unit
-    method item_extension : Format.formatter -> Parsetree.extension -> unit
-  end
-val default : printer
 val toplevel_phrase : Format.formatter -> Parsetree.toplevel_phrase -> unit
 val expression : Format.formatter -> Parsetree.expression -> unit
 val string_of_expression : Parsetree.expression -> string
diff --git a/parsing/printast.ml b/parsing/printast.ml
index 0f246db4..673defb6 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -238,6 +238,9 @@ and pattern i ppf x =
   | Ppat_exception p ->
       line i ppf "Ppat_exception\n";
       pattern i ppf p
+  | Ppat_open (m,p) ->
+      line i ppf "Ppat_open \"%a\"\n" fmt_longident_loc m;
+      pattern i ppf p
   | Ppat_extension (s, arg) ->
       line i ppf "Ppat_extension \"%s\"\n" s.txt;
       payload i ppf arg
@@ -341,6 +344,10 @@ and expression i ppf x =
       line i ppf "Pexp_letmodule %a\n" fmt_string_loc s;
       module_expr i ppf me;
       expression i ppf e;
+  | Pexp_letexception (cd, e) ->
+      line i ppf "Pexp_letexception\n";
+      extension_constructor i ppf cd;
+      expression i ppf e;
   | Pexp_assert (e) ->
       line i ppf "Pexp_assert\n";
       expression i ppf e;
diff --git a/parsing/syntaxerr.ml b/parsing/syntaxerr.ml
index 96ec79e2..0bb55ab6 100644
--- a/parsing/syntaxerr.ml
+++ b/parsing/syntaxerr.ml
@@ -30,9 +30,9 @@ exception Escape_error
 
 let prepare_error = function
   | Unclosed(opening_loc, opening, closing_loc, closing) ->
-      Location.errorf_prefixed ~loc:closing_loc
+      Location.errorf ~loc:closing_loc
         ~sub:[
-          Location.errorf_prefixed ~loc:opening_loc
+          Location.errorf ~loc:opening_loc
             "This '%s' might be unmatched" opening
         ]
         ~if_highlight:
@@ -42,24 +42,24 @@ let prepare_error = function
         "Syntax error: '%s' expected" closing
 
   | Expecting (loc, nonterm) ->
-      Location.errorf_prefixed ~loc "Syntax error: %s expected." nonterm
+      Location.errorf ~loc "Syntax error: %s expected." nonterm
   | Not_expecting (loc, nonterm) ->
-      Location.errorf_prefixed ~loc "Syntax error: %s not expected." nonterm
+      Location.errorf ~loc "Syntax error: %s not expected." nonterm
   | Applicative_path loc ->
-      Location.errorf_prefixed ~loc
+      Location.errorf ~loc
         "Syntax error: applicative paths of the form F(X).t \
          are not supported when the option -no-app-func is set."
   | Variable_in_scope (loc, var) ->
-      Location.errorf_prefixed ~loc
+      Location.errorf ~loc
         "In this scoped type, variable '%s \
          is reserved for the local type %s."
          var var
   | Other loc ->
-      Location.errorf_prefixed ~loc "Syntax error"
+      Location.errorf ~loc "Syntax error"
   | Ill_formed_ast (loc, s) ->
-      Location.errorf_prefixed ~loc "broken invariant in parsetree: %s" s
+      Location.errorf ~loc "broken invariant in parsetree: %s" s
   | Invalid_package_type (loc, s) ->
-      Location.errorf_prefixed ~loc "invalid package type: %s" s
+      Location.errorf ~loc "invalid package type: %s" s
 
 let () =
   Location.register_error_of_exn
diff --git a/parsing/syntaxerr.mli b/parsing/syntaxerr.mli
index 364fbe3d..319eb579 100644
--- a/parsing/syntaxerr.mli
+++ b/parsing/syntaxerr.mli
@@ -13,7 +13,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(* Auxiliary type for reporting syntax errors *)
+(** Auxiliary type for reporting syntax errors *)
 
 open Format
 
@@ -31,7 +31,7 @@ exception Error of error
 exception Escape_error
 
 val report_error: formatter -> error -> unit
- (* Deprecated.  Use Location.{error_of_exn, report_error}. *)
+ (** @deprecated Use {!Location.error_of_exn}, {!Location.report_error}. *)
 
 val location_of_error: error -> Location.t
 val ill_formed_ast: Location.t -> string -> 'a
diff --git a/stdlib/.depend b/stdlib/.depend
index b3815165..45827a92 100644
--- a/stdlib/.depend
+++ b/stdlib/.depend
@@ -1,186 +1,189 @@
-arg.cmi :
-array.cmi :
-arrayLabels.cmi :
-buffer.cmi :
-bytes.cmi :
-bytesLabels.cmi :
-callback.cmi :
-camlinternalFormat.cmi : camlinternalFormatBasics.cmi buffer.cmi
-camlinternalFormatBasics.cmi :
-camlinternalLazy.cmi :
-camlinternalMod.cmi : obj.cmi
-camlinternalOO.cmi : obj.cmi
-char.cmi :
-complex.cmi :
-digest.cmi :
-ephemeron.cmi : hashtbl.cmi
-filename.cmi :
-format.cmi : pervasives.cmi buffer.cmi
-gc.cmi :
-genlex.cmi : stream.cmi
-hashtbl.cmi :
-int32.cmi :
-int64.cmi :
-lazy.cmi :
-lexing.cmi :
-list.cmi :
-listLabels.cmi :
-map.cmi :
-marshal.cmi :
-moreLabels.cmi : set.cmi map.cmi hashtbl.cmi
-nativeint.cmi :
-obj.cmi : int32.cmi
-oo.cmi : camlinternalOO.cmi
-parsing.cmi : obj.cmi lexing.cmi
-pervasives.cmi : camlinternalFormatBasics.cmi
-printexc.cmi :
-printf.cmi : buffer.cmi
-queue.cmi :
-random.cmi : nativeint.cmi int64.cmi int32.cmi
-scanf.cmi : pervasives.cmi
-set.cmi :
-sort.cmi :
-stack.cmi :
-stdLabels.cmi : stringLabels.cmi listLabels.cmi bytesLabels.cmi \
-    arrayLabels.cmi
-stream.cmi :
-string.cmi :
-stringLabels.cmi :
-sys.cmi :
-uchar.cmi : format.cmi
-weak.cmi : hashtbl.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 \
     arg.cmi
+arg.cmi :
 array.cmo : array.cmi
 array.cmx : array.cmi
+array.cmi :
 arrayLabels.cmo : array.cmi arrayLabels.cmi
 arrayLabels.cmx : array.cmx arrayLabels.cmi
+arrayLabels.cmi :
 buffer.cmo : sys.cmi string.cmi bytes.cmi buffer.cmi
 buffer.cmx : sys.cmx string.cmx bytes.cmx buffer.cmi
-bytes.cmo : pervasives.cmi list.cmi char.cmi bytes.cmi
-bytes.cmx : pervasives.cmx list.cmx char.cmx bytes.cmi
+buffer.cmi :
+bytes.cmo : pervasives.cmi char.cmi bytes.cmi
+bytes.cmx : pervasives.cmx char.cmx bytes.cmi
+bytes.cmi :
 bytesLabels.cmo : bytes.cmi bytesLabels.cmi
 bytesLabels.cmx : bytes.cmx bytesLabels.cmi
+bytesLabels.cmi :
 callback.cmo : obj.cmi callback.cmi
 callback.cmx : obj.cmx callback.cmi
+callback.cmi :
 camlinternalFormat.cmo : sys.cmi string.cmi char.cmi \
     camlinternalFormatBasics.cmi bytes.cmi buffer.cmi camlinternalFormat.cmi
 camlinternalFormat.cmx : sys.cmx string.cmx char.cmx \
     camlinternalFormatBasics.cmx bytes.cmx buffer.cmx camlinternalFormat.cmi
+camlinternalFormat.cmi : camlinternalFormatBasics.cmi buffer.cmi
 camlinternalFormatBasics.cmo : camlinternalFormatBasics.cmi
 camlinternalFormatBasics.cmx : camlinternalFormatBasics.cmi
+camlinternalFormatBasics.cmi :
 camlinternalLazy.cmo : obj.cmi camlinternalLazy.cmi
 camlinternalLazy.cmx : obj.cmx camlinternalLazy.cmi
+camlinternalLazy.cmi :
 camlinternalMod.cmo : obj.cmi camlinternalOO.cmi array.cmi \
     camlinternalMod.cmi
 camlinternalMod.cmx : obj.cmx camlinternalOO.cmx array.cmx \
     camlinternalMod.cmi
+camlinternalMod.cmi : obj.cmi
 camlinternalOO.cmo : sys.cmi string.cmi obj.cmi map.cmi list.cmi char.cmi \
     array.cmi camlinternalOO.cmi
 camlinternalOO.cmx : sys.cmx string.cmx obj.cmx map.cmx list.cmx char.cmx \
     array.cmx camlinternalOO.cmi
+camlinternalOO.cmi : obj.cmi
 char.cmo : char.cmi
 char.cmx : char.cmi
+char.cmi :
 complex.cmo : complex.cmi
 complex.cmx : complex.cmi
+complex.cmi :
 digest.cmo : string.cmi char.cmi bytes.cmi digest.cmi
 digest.cmx : string.cmx char.cmx bytes.cmx digest.cmi
+digest.cmi :
 ephemeron.cmo : sys.cmi random.cmi obj.cmi lazy.cmi hashtbl.cmi array.cmi \
     ephemeron.cmi
 ephemeron.cmx : sys.cmx random.cmx obj.cmx lazy.cmx hashtbl.cmx array.cmx \
     ephemeron.cmi
+ephemeron.cmi : hashtbl.cmi
 filename.cmo : sys.cmi string.cmi random.cmi printf.cmi lazy.cmi buffer.cmi \
     filename.cmi
 filename.cmx : sys.cmx string.cmx random.cmx printf.cmx lazy.cmx buffer.cmx \
     filename.cmi
+filename.cmi :
 format.cmo : string.cmi pervasives.cmi camlinternalFormatBasics.cmi \
     camlinternalFormat.cmi buffer.cmi format.cmi
 format.cmx : string.cmx pervasives.cmx camlinternalFormatBasics.cmx \
     camlinternalFormat.cmx buffer.cmx format.cmi
+format.cmi : pervasives.cmi buffer.cmi
 gc.cmo : sys.cmi string.cmi printf.cmi gc.cmi
 gc.cmx : sys.cmx string.cmx printf.cmx gc.cmi
+gc.cmi :
 genlex.cmo : string.cmi stream.cmi list.cmi hashtbl.cmi char.cmi bytes.cmi \
     genlex.cmi
 genlex.cmx : string.cmx stream.cmx list.cmx hashtbl.cmx char.cmx bytes.cmx \
     genlex.cmi
+genlex.cmi : stream.cmi
 hashtbl.cmo : sys.cmi string.cmi random.cmi obj.cmi lazy.cmi array.cmi \
     hashtbl.cmi
 hashtbl.cmx : sys.cmx string.cmx random.cmx obj.cmx lazy.cmx array.cmx \
     hashtbl.cmi
+hashtbl.cmi :
 int32.cmo : pervasives.cmi int32.cmi
 int32.cmx : pervasives.cmx int32.cmi
+int32.cmi :
 int64.cmo : pervasives.cmi int64.cmi
 int64.cmx : pervasives.cmx int64.cmi
+int64.cmi :
 lazy.cmo : obj.cmi camlinternalLazy.cmi lazy.cmi
 lazy.cmx : obj.cmx camlinternalLazy.cmx lazy.cmi
+lazy.cmi :
 lexing.cmo : sys.cmi string.cmi bytes.cmi array.cmi lexing.cmi
 lexing.cmx : sys.cmx string.cmx bytes.cmx array.cmx lexing.cmi
+lexing.cmi :
 list.cmo : list.cmi
 list.cmx : list.cmi
+list.cmi :
 listLabels.cmo : list.cmi listLabels.cmi
 listLabels.cmx : list.cmx listLabels.cmi
+listLabels.cmi :
 map.cmo : map.cmi
 map.cmx : map.cmi
+map.cmi :
 marshal.cmo : bytes.cmi marshal.cmi
 marshal.cmx : bytes.cmx marshal.cmi
+marshal.cmi :
 moreLabels.cmo : set.cmi map.cmi hashtbl.cmi moreLabels.cmi
 moreLabels.cmx : set.cmx map.cmx hashtbl.cmx moreLabels.cmi
+moreLabels.cmi : set.cmi map.cmi hashtbl.cmi
 nativeint.cmo : sys.cmi pervasives.cmi nativeint.cmi
 nativeint.cmx : sys.cmx pervasives.cmx nativeint.cmi
+nativeint.cmi :
 obj.cmo : marshal.cmi int32.cmi obj.cmi
 obj.cmx : marshal.cmx int32.cmx obj.cmi
+obj.cmi : int32.cmi
 oo.cmo : camlinternalOO.cmi oo.cmi
 oo.cmx : camlinternalOO.cmx oo.cmi
+oo.cmi : camlinternalOO.cmi
 parsing.cmo : obj.cmi lexing.cmi array.cmi parsing.cmi
 parsing.cmx : obj.cmx lexing.cmx array.cmx parsing.cmi
+parsing.cmi : obj.cmi lexing.cmi
 pervasives.cmo : camlinternalFormatBasics.cmi pervasives.cmi
 pervasives.cmx : camlinternalFormatBasics.cmx pervasives.cmi
+pervasives.cmi : camlinternalFormatBasics.cmi
 printexc.cmo : printf.cmi pervasives.cmi obj.cmi buffer.cmi array.cmi \
     printexc.cmi
 printexc.cmx : printf.cmx pervasives.cmx obj.cmx buffer.cmx array.cmx \
     printexc.cmi
+printexc.cmi :
 printf.cmo : camlinternalFormatBasics.cmi camlinternalFormat.cmi buffer.cmi \
     printf.cmi
 printf.cmx : camlinternalFormatBasics.cmx camlinternalFormat.cmx buffer.cmx \
     printf.cmi
+printf.cmi : buffer.cmi
 queue.cmo : queue.cmi
 queue.cmx : queue.cmi
+queue.cmi :
 random.cmo : string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \
     digest.cmi char.cmi array.cmi random.cmi
 random.cmx : string.cmx pervasives.cmx nativeint.cmx int64.cmx int32.cmx \
     digest.cmx char.cmx array.cmx random.cmi
+random.cmi : nativeint.cmi int64.cmi int32.cmi
 scanf.cmo : string.cmi printf.cmi pervasives.cmi list.cmi \
     camlinternalFormatBasics.cmi camlinternalFormat.cmi bytes.cmi buffer.cmi \
     scanf.cmi
 scanf.cmx : string.cmx printf.cmx pervasives.cmx list.cmx \
     camlinternalFormatBasics.cmx camlinternalFormat.cmx bytes.cmx buffer.cmx \
     scanf.cmi
+scanf.cmi : pervasives.cmi
 set.cmo : list.cmi set.cmi
 set.cmx : list.cmx set.cmi
+set.cmi :
 sort.cmo : array.cmi sort.cmi
 sort.cmx : array.cmx sort.cmi
+sort.cmi :
+spacetime.cmo : gc.cmi spacetime.cmi
+spacetime.cmx : gc.cmx spacetime.cmi
+spacetime.cmi :
 stack.cmo : list.cmi stack.cmi
 stack.cmx : list.cmx stack.cmi
+stack.cmi :
 stdLabels.cmo : stringLabels.cmi listLabels.cmi bytesLabels.cmi \
     arrayLabels.cmi stdLabels.cmi
 stdLabels.cmx : stringLabels.cmx listLabels.cmx bytesLabels.cmx \
     arrayLabels.cmx stdLabels.cmi
+stdLabels.cmi : stringLabels.cmi listLabels.cmi bytesLabels.cmi \
+    arrayLabels.cmi
 std_exit.cmo :
 std_exit.cmx :
 stream.cmo : string.cmi list.cmi lazy.cmi bytes.cmi stream.cmi
 stream.cmx : string.cmx list.cmx lazy.cmx bytes.cmx stream.cmi
-string.cmo : pervasives.cmi list.cmi bytes.cmi string.cmi
-string.cmx : pervasives.cmx list.cmx bytes.cmx string.cmi
+stream.cmi :
+string.cmo : pervasives.cmi bytes.cmi string.cmi
+string.cmx : pervasives.cmx bytes.cmx string.cmi
+string.cmi :
 stringLabels.cmo : string.cmi stringLabels.cmi
 stringLabels.cmx : string.cmx stringLabels.cmi
+stringLabels.cmi :
 sys.cmo : sys.cmi
 sys.cmx : sys.cmi
+sys.cmi :
 uchar.cmo : printf.cmi pervasives.cmi format.cmi char.cmi uchar.cmi
 uchar.cmx : printf.cmx pervasives.cmx format.cmx char.cmx uchar.cmi
+uchar.cmi : format.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
+weak.cmi : hashtbl.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 \
@@ -191,8 +194,8 @@ arrayLabels.cmo : array.cmi arrayLabels.cmi
 arrayLabels.p.cmx : array.cmx arrayLabels.cmi
 buffer.cmo : sys.cmi string.cmi bytes.cmi buffer.cmi
 buffer.p.cmx : sys.cmx string.cmx bytes.cmx buffer.cmi
-bytes.cmo : pervasives.cmi list.cmi char.cmi bytes.cmi
-bytes.p.cmx : pervasives.cmx list.cmx char.cmx bytes.cmi
+bytes.cmo : pervasives.cmi char.cmi bytes.cmi
+bytes.p.cmx : pervasives.cmx char.cmx bytes.cmi
 bytesLabels.cmo : bytes.cmi bytesLabels.cmi
 bytesLabels.p.cmx : bytes.cmx bytesLabels.cmi
 callback.cmo : obj.cmi callback.cmi
@@ -293,6 +296,8 @@ set.cmo : list.cmi set.cmi
 set.p.cmx : list.cmx set.cmi
 sort.cmo : array.cmi sort.cmi
 sort.p.cmx : array.cmx sort.cmi
+spacetime.cmo : gc.cmi spacetime.cmi
+spacetime.p.cmx : gc.cmx spacetime.cmi
 stack.cmo : list.cmi stack.cmi
 stack.p.cmx : list.cmx stack.cmi
 stdLabels.cmo : stringLabels.cmi listLabels.cmi bytesLabels.cmi \
@@ -303,8 +308,8 @@ std_exit.cmo :
 std_exit.cmx :
 stream.cmo : string.cmi list.cmi lazy.cmi bytes.cmi stream.cmi
 stream.p.cmx : string.cmx list.cmx lazy.cmx bytes.cmx stream.cmi
-string.cmo : pervasives.cmi list.cmi bytes.cmi string.cmi
-string.p.cmx : pervasives.cmx list.cmx bytes.cmx string.cmi
+string.cmo : pervasives.cmi bytes.cmi string.cmi
+string.p.cmx : pervasives.cmx bytes.cmx string.cmi
 stringLabels.cmo : string.cmi stringLabels.cmi
 stringLabels.p.cmx : string.cmx stringLabels.cmi
 sys.cmo : sys.cmi
diff --git a/stdlib/Makefile b/stdlib/Makefile
index 2beea0f2..05ee26ab 100644
--- a/stdlib/Makefile
+++ b/stdlib/Makefile
@@ -52,7 +52,7 @@ camlheader target_camlheader camlheader_ur \
 camlheaderd target_camlheaderd \
 camlheaderi target_camlheaderi: \
   header.c ../config/Makefile
-	if $(SHARPBANGSCRIPTS); then \
+	if $(HASHBANGSCRIPTS); then \
 	  for suff in '' d i; do \
 	    echo '#!$(BINDIR)/ocamlrun'$$suff > camlheader$$suff && \
 	    echo '#!$(TARGET_BINDIR)/ocamlrun'$$suff >target_camlheader$$suff; \
diff --git a/stdlib/Makefile.shared b/stdlib/Makefile.shared
index 0af8601b..1956657a 100755
--- a/stdlib/Makefile.shared
+++ b/stdlib/Makefile.shared
@@ -20,8 +20,9 @@ TARGET_BINDIR ?= $(BINDIR)
 
 COMPILER=../ocamlc
 CAMLC=$(CAMLRUN) $(COMPILER)
-COMPFLAGS=-strict-sequence -w +32+33..39+50 -g -warn-error A -bin-annot \
-	  -nostdlib -safe-string
+COMPFLAGS=-strict-sequence -absname -w +a-4-9-41-42-44-45-48 \
+          -g -warn-error A -bin-annot -nostdlib \
+          -safe-string -strict-formats
 ifeq "$(FLAMBDA)" "true"
 OPTCOMPFLAGS=-O3
 else
@@ -46,7 +47,8 @@ OTHERS=list.cmo char.cmo bytes.cmo string.cmo sys.cmo \
   genlex.cmo ephemeron.cmo \
   filename.cmo complex.cmo \
   arrayLabels.cmo listLabels.cmo bytesLabels.cmo \
-  stringLabels.cmo moreLabels.cmo stdLabels.cmo
+  stringLabels.cmo moreLabels.cmo stdLabels.cmo \
+  spacetime.cmo
 
 all: stdlib.cma std_exit.cmo camlheader target_camlheader camlheader_ur
 
@@ -107,8 +109,9 @@ clean::
 	           -p -c -o $*.p.cmx $<
 
 # Dependencies on the compiler
-$(OBJS) std_exit.cmo: $(COMPILER)
-$(OBJS:.cmo=.cmi) std_exit.cmi: $(COMPILER)
+COMPILER_DEPS=$(filter-out -use-prims, $(COMPILER))
+$(OBJS) std_exit.cmo: $(COMPILER_DEPS)
+$(OBJS:.cmo=.cmi) std_exit.cmi: $(COMPILER_DEPS)
 $(OBJS:.cmo=.cmx) std_exit.cmx: $(OPTCOMPILER)
 $(OBJS:.cmo=.p.cmx) std_exit.p.cmx: $(OPTCOMPILER)
 
@@ -131,5 +134,5 @@ include .depend
 # .p.cmx files.  When the compiler imports another compilation unit,
 # it looks for the .cmx file (not .p.cmx).
 depend:
-	$(CAMLDEP) *.mli *.ml > .depend
-	$(CAMLDEP) *.ml | sed -e 's/\.cmx : /.p.cmx : /g' >>.depend
+	$(CAMLDEP) -slash *.mli *.ml > .depend
+	$(CAMLDEP) -slash *.ml | sed -e 's/\.cmx : /.p.cmx : /g' >>.depend
diff --git a/stdlib/StdlibModules b/stdlib/StdlibModules
index 1f516b9b..b65e9deb 100644
--- a/stdlib/StdlibModules
+++ b/stdlib/StdlibModules
@@ -19,6 +19,7 @@
 # It is used in particular to know what to expunge in toplevels.
 
 STDLIB_MODULES=\
+  spacetime \
   arg \
   array \
   arrayLabels \
diff --git a/stdlib/arg.ml b/stdlib/arg.ml
index 65435c5f..9b0bce99 100644
--- a/stdlib/arg.ml
+++ b/stdlib/arg.ml
@@ -53,7 +53,7 @@ open Printf
 let rec assoc3 x l =
   match l with
   | [] -> raise Not_found
-  | (y1, y2, y3) :: t when y1 = x -> y2
+  | (y1, y2, _) :: _ when y1 = x -> y2
   | _ :: t -> assoc3 x t
 
 
@@ -293,7 +293,7 @@ let add_padding len ksd =
       (* Do not pad undocumented options, so that they still don't show up when
        * run through [usage] or [parse]. *)
       ksd
-  | (kwd, (Symbol (l, _) as spec), msg) ->
+  | (kwd, (Symbol _ as spec), msg) ->
       let cutcol = second_word msg in
       let spaces = String.make ((max 0 (len - cutcol)) + 3) ' ' in
       (kwd, spec, "\n" ^ spaces ^ msg)
diff --git a/stdlib/array.ml b/stdlib/array.ml
index 9b19843c..a4270f27 100644
--- a/stdlib/array.ml
+++ b/stdlib/array.ml
@@ -131,8 +131,7 @@ let to_list a =
 (* Cannot use List.length here because the List module depends on Array. *)
 let rec list_length accu = function
   | [] -> accu
-  | h::t -> list_length (succ accu) t
-
+  | _::t -> list_length (succ accu) t
 
 let of_list = function
     [] -> [||]
diff --git a/stdlib/array.mli b/stdlib/array.mli
index 872423df..f75b6137 100644
--- a/stdlib/array.mli
+++ b/stdlib/array.mli
@@ -174,13 +174,15 @@ val fold_right : ('b -> 'a -> 'a) -> 'b array -> 'a -> 'a
 val iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit
 (** [Array.iter2 f a b] applies function [f] to all the elements of [a]
    and [b].
-   Raise [Invalid_argument] if the arrays are not the same size. *)
+   Raise [Invalid_argument] if the arrays are not the same size.
+   @since 4.03.0 *)
 
 val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
 (** [Array.map2 f a b] applies function [f] to all the elements of [a]
    and [b], and builds an array with the results returned by [f]:
    [[| f a.(0) b.(0); ...; f a.(Array.length a - 1) b.(Array.length b - 1)|]].
-   Raise [Invalid_argument] if the arrays are not the same size. *)
+   Raise [Invalid_argument] if the arrays are not the same size.
+   @since 4.03.0 *)
 
 
 (** {6 Array scanning} *)
@@ -189,20 +191,24 @@ val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
 val for_all : ('a -> bool) -> 'a array -> bool
 (** [Array.for_all p [|a1; ...; an|]] checks if all elements of the array
    satisfy the predicate [p]. That is, it returns
-   [(p a1) && (p a2) && ... && (p an)]. *)
+   [(p a1) && (p a2) && ... && (p an)].
+   @since 4.03.0 *)
 
 val exists : ('a -> bool) -> 'a array -> bool
 (** [Array.exists p [|a1; ...; an|]] checks if at least one element of
     the array satisfies the predicate [p]. That is, it returns
-    [(p a1) || (p a2) || ... || (p an)]. *)
+    [(p a1) || (p a2) || ... || (p an)].
+    @since 4.03.0 *)
 
 val mem : 'a -> 'a array -> bool
 (** [mem a l] is true if and only if [a] is equal
-   to an element of [l]. *)
+   to an element of [l].
+   @since 4.03.0 *)
 
 val memq : 'a -> 'a array -> bool
 (** Same as {!Array.mem}, but uses physical equality instead of structural
-   equality to compare array elements. *)
+   equality to compare array elements.
+   @since 4.03.0 *)
 
 
 (** {6 Sorting} *)
diff --git a/stdlib/buffer.ml b/stdlib/buffer.ml
index 3a2668a1..51ab6412 100644
--- a/stdlib/buffer.ml
+++ b/stdlib/buffer.ml
@@ -81,7 +81,7 @@ let add_char b c =
   b.position <- pos + 1
 
 let add_substring b s offset len =
-  if offset < 0 || len < 0 || offset + len > String.length s
+  if offset < 0 || len < 0 || offset > String.length s - len
   then invalid_arg "Buffer.add_substring/add_subbytes";
   let new_position = b.position + len in
   if new_position > b.length then resize b len;
diff --git a/stdlib/bytes.ml b/stdlib/bytes.ml
index 7ee98d5e..24e97cce 100644
--- a/stdlib/bytes.ml
+++ b/stdlib/bytes.ml
@@ -15,20 +15,26 @@
 
 (* Byte sequence operations *)
 
-external length : bytes -> int = "%string_length"
+(* WARNING: Some functions in this file are duplicated in string.ml for
+   efficiency reasons. When you modify the one in this file you need to
+   modify its duplicate in string.ml.
+   These functions have a "duplicated" comment above their definition.
+*)
+
+external length : bytes -> int = "%bytes_length"
 external string_length : string -> int = "%string_length"
-external get : bytes -> int -> char = "%string_safe_get"
-external set : bytes -> int -> char -> unit = "%string_safe_set"
-external create : int -> bytes = "caml_create_string"
-external unsafe_get : bytes -> int -> char = "%string_unsafe_get"
-external unsafe_set : bytes -> int -> char -> unit = "%string_unsafe_set"
+external get : bytes -> int -> char = "%bytes_safe_get"
+external set : bytes -> int -> char -> unit = "%bytes_safe_set"
+external create : int -> bytes = "caml_create_bytes"
+external unsafe_get : bytes -> int -> char = "%bytes_unsafe_get"
+external unsafe_set : bytes -> int -> char -> unit = "%bytes_unsafe_set"
 external unsafe_fill : bytes -> int -> int -> char -> unit
-                     = "caml_fill_string" [@@noalloc]
-external unsafe_to_string : bytes -> string = "%identity"
-external unsafe_of_string : string -> bytes = "%identity"
+                     = "caml_fill_bytes" [@@noalloc]
+external unsafe_to_string : bytes -> string = "%bytes_to_string"
+external unsafe_of_string : string -> bytes = "%bytes_of_string"
 
 external unsafe_blit : bytes -> int -> bytes -> int -> int -> unit
-                     = "caml_blit_string" [@@noalloc]
+                     = "caml_blit_bytes" [@@noalloc]
 external unsafe_blit_string : string -> int -> bytes -> int -> int -> unit
                      = "caml_blit_string" [@@noalloc]
 
@@ -91,29 +97,36 @@ let blit_string s1 ofs1 s2 ofs2 len =
   then invalid_arg "String.blit / Bytes.blit_string"
   else unsafe_blit_string s1 ofs1 s2 ofs2 len
 
+(* duplicated in string.ml *)
 let iter f a =
   for i = 0 to length a - 1 do f(unsafe_get a i) done
 
+(* duplicated in string.ml *)
 let iteri f a =
   for i = 0 to length a - 1 do f i (unsafe_get a i) done
 
-let concat sep l =
-  match l with
-    [] -> empty
+let ensure_ge x y = if x >= y then x else invalid_arg "Bytes.concat"
+
+let rec sum_lengths acc seplen = function
+  | [] -> acc
+  | hd :: [] -> length hd + acc
+  | hd :: tl -> sum_lengths (ensure_ge (length hd + seplen + acc) acc) seplen tl
+
+let rec unsafe_blits dst pos sep seplen = function
+    [] -> dst
+  | hd :: [] ->
+    unsafe_blit hd 0 dst pos (length hd); dst
   | hd :: tl ->
-      let num = ref 0 and len = ref 0 in
-      List.iter (fun s -> incr num; len := !len + length s) l;
-      let r = create (!len + length sep * (!num - 1)) in
-      unsafe_blit hd 0 r 0 (length hd);
-      let pos = ref(length hd) in
-      List.iter
-        (fun s ->
-          unsafe_blit sep 0 r !pos (length sep);
-          pos := !pos + length sep;
-          unsafe_blit s 0 r !pos (length s);
-          pos := !pos + length s)
-        tl;
-      r
+    unsafe_blit hd 0 dst pos (length hd);
+    unsafe_blit sep 0 dst (pos + length hd) seplen;
+    unsafe_blits dst (pos + length hd + seplen) sep seplen tl
+
+let concat sep = function
+    [] -> empty
+  | l -> let seplen = length sep in
+          unsafe_blits 
+            (create (sum_lengths 0 seplen l))
+            0 sep seplen l
 
 let cat s1 s2 =
   let l1 = length s1 in
@@ -215,23 +228,29 @@ let apply1 f s =
 let capitalize_ascii s = apply1 Char.uppercase_ascii s
 let uncapitalize_ascii s = apply1 Char.lowercase_ascii s
 
+(* duplicated in string.ml *)
 let rec index_rec s lim i c =
   if i >= lim then raise Not_found else
   if unsafe_get s i = c then i else index_rec s lim (i + 1) c
 
+(* duplicated in string.ml *)
 let index s c = index_rec s (length s) 0 c
 
+(* duplicated in string.ml *)
 let index_from s i c =
   let l = length s in
   if i < 0 || i > l then invalid_arg "String.index_from / Bytes.index_from" else
   index_rec s l i c
 
+(* duplicated in string.ml *)
 let rec rindex_rec s i c =
   if i < 0 then raise Not_found else
   if unsafe_get s i = c then i else rindex_rec s (i - 1) c
 
+(* duplicated in string.ml *)
 let rindex s c = rindex_rec s (length s - 1) c
 
+(* duplicated in string.ml *)
 let rindex_from s i c =
   if i < -1 || i >= length s then
     invalid_arg "String.rindex_from / Bytes.rindex_from"
@@ -239,6 +258,7 @@ let rindex_from s i c =
     rindex_rec s i c
 
 
+(* duplicated in string.ml *)
 let contains_from s i c =
   let l = length s in
   if i < 0 || i > l then
@@ -247,8 +267,10 @@ let contains_from s i c =
     try ignore (index_rec s l i c); true with Not_found -> false
 
 
+(* duplicated in string.ml *)
 let contains s c = contains_from s 0 c
 
+(* duplicated in string.ml *)
 let rcontains_from s i c =
   if i < 0 || i >= length s then
     invalid_arg "String.rcontains_from / Bytes.rcontains_from"
@@ -259,7 +281,7 @@ let rcontains_from s i c =
 type t = bytes
 
 let compare (x: t) (y: t) = Pervasives.compare x y
-external equal : t -> t -> bool = "caml_string_equal"
+external equal : t -> t -> bool = "caml_bytes_equal"
 
 (* Deprecated functions implemented via other deprecated functions *)
 [@@@ocaml.warning "-3"]
diff --git a/stdlib/bytes.mli b/stdlib/bytes.mli
index 3b03382c..a6172d85 100644
--- a/stdlib/bytes.mli
+++ b/stdlib/bytes.mli
@@ -42,21 +42,21 @@
    @since 4.02.0
  *)
 
-external length : bytes -> int = "%string_length"
+external length : bytes -> int = "%bytes_length"
 (** Return the length (number of bytes) of the argument. *)
 
-external get : bytes -> int -> char = "%string_safe_get"
+external get : bytes -> int -> char = "%bytes_safe_get"
 (** [get s n] returns the byte at index [n] in argument [s].
 
     Raise [Invalid_argument] if [n] not a valid index in [s]. *)
 
-external set : bytes -> int -> char -> unit = "%string_safe_set"
+external set : bytes -> int -> char -> unit = "%bytes_safe_set"
 (** [set s n c] modifies [s] in place, replacing the byte at index [n]
     with [c].
 
     Raise [Invalid_argument] if [n] is not a valid index in [s]. *)
 
-external create : int -> bytes = "caml_create_string"
+external create : int -> bytes = "caml_create_bytes"
 (** [create n] returns a new byte sequence of length [n]. The
     sequence is uninitialized and contains arbitrary bytes.
 
@@ -424,10 +424,10 @@ let s = Bytes.of_string "hello"
 
 (* The following is for system use only. Do not call directly. *)
 
-external unsafe_get : bytes -> int -> char = "%string_unsafe_get"
-external unsafe_set : bytes -> int -> char -> unit = "%string_unsafe_set"
+external unsafe_get : bytes -> int -> char = "%bytes_unsafe_get"
+external unsafe_set : bytes -> int -> char -> unit = "%bytes_unsafe_set"
 external unsafe_blit :
   bytes -> int -> bytes -> int -> int -> unit
-  = "caml_blit_string" [@@noalloc]
+  = "caml_blit_bytes" [@@noalloc]
 external unsafe_fill :
-  bytes -> int -> int -> char -> unit = "caml_fill_string" [@@noalloc]
+  bytes -> int -> int -> char -> unit = "caml_fill_bytes" [@@noalloc]
diff --git a/stdlib/bytesLabels.mli b/stdlib/bytesLabels.mli
index b22139e8..fb9404b9 100644
--- a/stdlib/bytesLabels.mli
+++ b/stdlib/bytesLabels.mli
@@ -17,22 +17,22 @@
     @since 4.02.0
  *)
 
-external length : bytes -> int = "%string_length"
+external length : bytes -> int = "%bytes_length"
 (** Return the length (number of bytes) of the argument. *)
 
-external get : bytes -> int -> char = "%string_safe_get"
+external get : bytes -> int -> char = "%bytes_safe_get"
 (** [get s n] returns the byte at index [n] in argument [s].
 
     Raise [Invalid_argument] if [n] not a valid index in [s]. *)
 
 
-external set : bytes -> int -> char -> unit = "%string_safe_set"
+external set : bytes -> int -> char -> unit = "%bytes_safe_set"
 (** [set s n c] modifies [s] in place, replacing the byte at index [n]
     with [c].
 
     Raise [Invalid_argument] if [n] is not a valid index in [s]. *)
 
-external create : int -> bytes = "caml_create_string"
+external create : int -> bytes = "caml_create_bytes"
 (** [create n] returns a new byte sequence of length [n]. The
     sequence is uninitialized and contains arbitrary bytes.
 
@@ -206,12 +206,12 @@ val compare: t -> t -> int
 
 (* The following is for system use only. Do not call directly. *)
 
-external unsafe_get : bytes -> int -> char = "%string_unsafe_get"
-external unsafe_set : bytes -> int -> char -> unit = "%string_unsafe_set"
+external unsafe_get : bytes -> int -> char = "%bytes_unsafe_get"
+external unsafe_set : bytes -> int -> char -> unit = "%bytes_unsafe_set"
 external unsafe_blit :
   src:bytes -> src_pos:int -> dst:bytes -> dst_pos:int -> len:int ->
-    unit = "caml_blit_string" [@@noalloc]
+    unit = "caml_blit_bytes" [@@noalloc]
 external unsafe_fill :
-  bytes -> pos:int -> len:int -> char -> unit = "caml_fill_string" [@@noalloc]
+  bytes -> pos:int -> len:int -> char -> unit = "caml_fill_bytes" [@@noalloc]
 val unsafe_to_string : bytes -> string
 val unsafe_of_string : string -> bytes
diff --git a/stdlib/camlinternalFormat.ml b/stdlib/camlinternalFormat.ml
index 2391af78..9c0574dd 100644
--- a/stdlib/camlinternalFormat.ml
+++ b/stdlib/camlinternalFormat.ml
@@ -2012,7 +2012,7 @@ let fmt_ebb_of_string ?legacy_behavior str =
   (*   - zero:  is the '0' flag defined in the current micro-format.  *)
   (*   - minus: is the '-' flag defined in the current micro-format.  *)
   (*   - plus:  is the '+' flag defined in the current micro-format.  *)
-  (*   - sharp: is the '#' flag defined in the current micro-format.  *)
+  (*   - hash:  is the '#' flag defined in the current micro-format.  *)
   (*   - space: is the ' ' flag defined in the current micro-format.  *)
   (*   - ign:   is the '_' flag defined in the current micro-format.  *)
   (*   - pad: padding of the current micro-format.                    *)
@@ -2105,7 +2105,7 @@ let fmt_ebb_of_string ?legacy_behavior str =
   fun pct_ind str_ind end_ind ign ->
     let zero = ref false and minus = ref false
     and plus = ref false and space = ref false
-    and sharp = ref false in
+    and hash = ref false in
     let set_flag str_ind flag =
       (* in legacy mode, duplicate flags are accepted *)
       if !flag && not legacy_behavior then
@@ -2120,11 +2120,11 @@ let fmt_ebb_of_string ?legacy_behavior str =
       | '0' -> set_flag str_ind zero;  read_flags (str_ind + 1)
       | '-' -> set_flag str_ind minus; read_flags (str_ind + 1)
       | '+' -> set_flag str_ind plus;  read_flags (str_ind + 1)
-      | '#' -> set_flag str_ind sharp; read_flags (str_ind + 1)
+      | '#' -> set_flag str_ind hash; read_flags (str_ind + 1)
       | ' ' -> set_flag str_ind space; read_flags (str_ind + 1)
       | _ ->
         parse_padding pct_ind str_ind end_ind
-          !zero !minus !plus !sharp !space ign
+          !zero !minus !plus !hash !space ign
       end
     in
     read_flags str_ind
@@ -2133,7 +2133,7 @@ let fmt_ebb_of_string ?legacy_behavior str =
   and parse_padding : type e f .
       int -> int -> int -> bool -> bool -> bool -> bool -> bool -> bool ->
         (_, _, e, f) fmt_ebb =
-  fun pct_ind str_ind end_ind zero minus plus sharp space ign ->
+  fun pct_ind str_ind end_ind zero minus plus hash space ign ->
     if str_ind = end_ind then unexpected_end_of_format end_ind;
     let padty = match zero, minus with
       | false, false -> Right
@@ -2145,26 +2145,26 @@ let fmt_ebb_of_string ?legacy_behavior str =
     match str.[str_ind] with
     | '0' .. '9' ->
       let new_ind, width = parse_positive str_ind end_ind 0 in
-      parse_after_padding pct_ind new_ind end_ind minus plus sharp space ign
+      parse_after_padding pct_ind new_ind end_ind minus plus hash space ign
         (Lit_padding (padty, width))
     | '*' ->
-      parse_after_padding pct_ind (str_ind + 1) end_ind minus plus sharp space
+      parse_after_padding pct_ind (str_ind + 1) end_ind minus plus hash space
         ign (Arg_padding padty)
     | _ ->
       begin match padty with
       | Left  ->
         if not legacy_behavior then
           invalid_format_without (str_ind - 1) '-' "padding";
-        parse_after_padding pct_ind str_ind end_ind minus plus sharp space ign
+        parse_after_padding pct_ind str_ind end_ind minus plus hash space ign
           No_padding
       | Zeros ->
          (* a '0' padding indication not followed by anything should
            be interpreted as a Right padding of width 0. This is used
            by scanning conversions %0s and %0c *)
-        parse_after_padding pct_ind str_ind end_ind minus plus sharp space ign
+        parse_after_padding pct_ind str_ind end_ind minus plus hash space ign
           (Lit_padding (Right, 0))
       | Right ->
-        parse_after_padding pct_ind str_ind end_ind minus plus sharp space ign
+        parse_after_padding pct_ind str_ind end_ind minus plus hash space ign
           No_padding
       end
 
@@ -2172,25 +2172,25 @@ let fmt_ebb_of_string ?legacy_behavior str =
   and parse_after_padding : type x e f .
       int -> int -> int -> bool -> bool -> bool -> bool -> bool ->
         (x, _) padding -> (_, _, e, f) fmt_ebb =
-  fun pct_ind str_ind end_ind minus plus sharp space ign pad ->
+  fun pct_ind str_ind end_ind minus plus hash space ign pad ->
     if str_ind = end_ind then unexpected_end_of_format end_ind;
     match str.[str_ind] with
     | '.' ->
-      parse_precision pct_ind (str_ind + 1) end_ind minus plus sharp space ign
+      parse_precision pct_ind (str_ind + 1) end_ind minus plus hash space ign
         pad
     | symb ->
-      parse_conversion pct_ind (str_ind + 1) end_ind plus sharp space ign pad
+      parse_conversion pct_ind (str_ind + 1) end_ind plus hash space ign pad
         No_precision pad symb
 
   (* Read the digital or '*' precision. *)
   and parse_precision : type x e f .
       int -> int -> int -> bool -> bool -> bool -> bool -> bool ->
         (x, _) padding -> (_, _, e, f) fmt_ebb =
-  fun pct_ind str_ind end_ind minus plus sharp space ign pad ->
+  fun pct_ind str_ind end_ind minus plus hash space ign pad ->
     if str_ind = end_ind then unexpected_end_of_format end_ind;
     let parse_literal minus str_ind =
       let new_ind, prec = parse_positive str_ind end_ind 0 in
-      parse_after_precision pct_ind new_ind end_ind minus plus sharp space ign
+      parse_after_precision pct_ind new_ind end_ind minus plus hash space ign
         pad (Lit_precision prec) in
     match str.[str_ind] with
     | '0' .. '9' -> parse_literal minus str_ind
@@ -2205,14 +2205,14 @@ let fmt_ebb_of_string ?legacy_behavior str =
          still blatantly wrong, as 123_456 or 0xFF are rejected. *)
       parse_literal (minus || symb = '-') (str_ind + 1)
     | '*' ->
-      parse_after_precision pct_ind (str_ind + 1) end_ind minus plus sharp space
+      parse_after_precision pct_ind (str_ind + 1) end_ind minus plus hash space
         ign pad Arg_precision
     | _ ->
       if legacy_behavior then
         (* note that legacy implementation did not ignore '.' without
            a number (as it does for padding indications), but
            interprets it as '.0' *)
-        parse_after_precision pct_ind str_ind end_ind minus plus sharp space ign
+        parse_after_precision pct_ind str_ind end_ind minus plus hash space ign
           pad (Lit_precision 0)
       else
         invalid_format_without (str_ind - 1) '.' "precision"
@@ -2221,10 +2221,10 @@ let fmt_ebb_of_string ?legacy_behavior str =
   and parse_after_precision : type x y z t e f .
       int -> int -> int -> bool -> bool -> bool -> bool -> bool ->
         (x, y) padding -> (z, t) precision -> (_, _, e, f) fmt_ebb =
-  fun pct_ind str_ind end_ind minus plus sharp space ign pad prec ->
+  fun pct_ind str_ind end_ind minus plus hash space ign pad prec ->
     if str_ind = end_ind then unexpected_end_of_format end_ind;
     let parse_conv (type u) (type v) (padprec : (u, v) padding) =
-      parse_conversion pct_ind (str_ind + 1) end_ind plus sharp space ign pad
+      parse_conversion pct_ind (str_ind + 1) end_ind plus hash space ign pad
         prec padprec str.[str_ind] in
     (* in legacy mode, some formats (%s and %S) accept a weird mix of
        padding and precision, which is merged as a single padding
@@ -2247,15 +2247,15 @@ let fmt_ebb_of_string ?legacy_behavior str =
   and parse_conversion : type x y z t u v e f .
       int -> int -> int -> bool -> bool -> bool -> bool -> (x, y) padding ->
         (z, t) precision -> (u, v) padding -> char -> (_, _, e, f) fmt_ebb =
-  fun pct_ind str_ind end_ind plus sharp space ign pad prec padprec symb ->
+  fun pct_ind str_ind end_ind plus hash space ign pad prec padprec symb ->
     (* Flags used to check option usages/compatibilities. *)
-    let plus_used  = ref false and sharp_used = ref false
+    let plus_used  = ref false and hash_used = ref false
     and space_used = ref false and ign_used   = ref false
     and pad_used   = ref false and prec_used  = ref false in
 
     (* Access to options, update flags. *)
     let get_plus    () = plus_used  := true; plus
-    and get_sharp   () = sharp_used := true; sharp
+    and get_hash   () = hash_used := true; hash
     and get_space   () = space_used := true; space
     and get_ign     () = ign_used   := true; ign
     and get_pad     () = pad_used   := true; pad
@@ -2374,7 +2374,7 @@ let fmt_ebb_of_string ?legacy_behavior str =
           make_padding_fmt_ebb pad fmt_rest in
         Fmt_EBB (Caml_string (pad', fmt_rest'))
     | 'd' | 'i' | 'x' | 'X' | 'o' | 'u' ->
-      let iconv = compute_int_conv pct_ind str_ind (get_plus ()) (get_sharp ())
+      let iconv = compute_int_conv pct_ind str_ind (get_plus ()) (get_hash ())
         (get_space ()) symb in
       let Fmt_EBB fmt_rest = parse str_ind end_ind in
       if get_ign () then
@@ -2402,7 +2402,7 @@ let fmt_ebb_of_string ?legacy_behavior str =
         Fmt_EBB (Scan_get_counter (counter, fmt_rest))
     | 'l' ->
       let iconv =
-        compute_int_conv pct_ind (str_ind + 1) (get_plus ()) (get_sharp ())
+        compute_int_conv pct_ind (str_ind + 1) (get_plus ()) (get_hash ())
           (get_space ()) str.[str_ind] in
       let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
       if get_ign () then
@@ -2415,7 +2415,7 @@ let fmt_ebb_of_string ?legacy_behavior str =
     | 'n' ->
       let iconv =
         compute_int_conv pct_ind (str_ind + 1) (get_plus ())
-          (get_sharp ()) (get_space ()) str.[str_ind] in
+          (get_hash ()) (get_space ()) str.[str_ind] in
       let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
       if get_ign () then
         let ignored = Ignored_nativeint (iconv, get_pad_opt '_') in
@@ -2426,7 +2426,7 @@ let fmt_ebb_of_string ?legacy_behavior str =
         Fmt_EBB (Nativeint (iconv, pad', prec', fmt_rest'))
     | 'L' ->
       let iconv =
-        compute_int_conv pct_ind (str_ind + 1) (get_plus ()) (get_sharp ())
+        compute_int_conv pct_ind (str_ind + 1) (get_plus ()) (get_hash ())
           (get_space ()) str.[str_ind] in
       let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
       if get_ign () then
@@ -2512,7 +2512,7 @@ let fmt_ebb_of_string ?legacy_behavior str =
     if not legacy_behavior then begin
     if not !plus_used && plus then
       incompatible_flag pct_ind str_ind symb "'+'";
-    if not !sharp_used && sharp then
+    if not !hash_used && hash then
       incompatible_flag pct_ind str_ind symb "'#'";
     if not !space_used && space then
       incompatible_flag pct_ind str_ind symb "' '";
@@ -2858,8 +2858,8 @@ let fmt_ebb_of_string ?legacy_behavior str =
     | 'L' -> Token_counter | _ -> assert false
 
   (* Convert (plus, symb) to its associated int_conv. *)
-  and compute_int_conv pct_ind str_ind plus sharp space symb =
-    match plus, sharp, space, symb with
+  and compute_int_conv pct_ind str_ind plus hash space symb =
+    match plus, hash, space, symb with
     | false, false, false, 'd' -> Int_d  | false, false, false, 'i' -> Int_i
     | false, false,  true, 'd' -> Int_sd | false, false,  true, 'i' -> Int_si
     |  true, false, false, 'd' -> Int_pd |  true, false, false, 'i' -> Int_pi
@@ -2878,15 +2878,15 @@ let fmt_ebb_of_string ?legacy_behavior str =
     | true, _, true, _ ->
       if legacy_behavior then
         (* plus and space: legacy implementation prefers plus *)
-        compute_int_conv pct_ind str_ind plus sharp false symb
+        compute_int_conv pct_ind str_ind plus hash false symb
       else incompatible_flag pct_ind str_ind ' ' "'+'"
     | false, _, true, _    ->
       if legacy_behavior then (* ignore *)
-        compute_int_conv pct_ind str_ind plus sharp false symb
+        compute_int_conv pct_ind str_ind plus hash false symb
       else incompatible_flag pct_ind str_ind symb "' '"
     | true, _, false, _    ->
       if legacy_behavior then (* ignore *)
-        compute_int_conv pct_ind str_ind false sharp space symb
+        compute_int_conv pct_ind str_ind false hash space symb
       else incompatible_flag pct_ind str_ind symb "'+'"
     | false, _, false, _ -> assert false
 
diff --git a/stdlib/camlinternalFormatBasics.ml b/stdlib/camlinternalFormatBasics.ml
index 539868e7..9dbd563d 100644
--- a/stdlib/camlinternalFormatBasics.ml
+++ b/stdlib/camlinternalFormatBasics.ml
@@ -540,7 +540,7 @@ let rec erase_rel : type a b c d e f g h i j k l .
     Bool_ty (erase_rel rest)
   | Format_arg_ty (ty, rest) ->
     Format_arg_ty (ty, erase_rel rest)
-  | Format_subst_ty (ty1, ty2, rest) ->
+  | Format_subst_ty (ty1, _ty2, rest) ->
     Format_subst_ty (ty1, ty1, erase_rel rest)
   | Alpha_ty rest ->
     Alpha_ty (erase_rel rest)
diff --git a/stdlib/camlinternalMod.ml b/stdlib/camlinternalMod.ml
index ea477e31..9e261926 100644
--- a/stdlib/camlinternalMod.ml
+++ b/stdlib/camlinternalMod.ml
@@ -71,4 +71,4 @@ let rec update_mod shape o n =
       for i = 0 to Array.length comps - 1 do
         update_mod comps.(i) (Obj.field o i) (Obj.field n i)
       done
-  | Value v -> () (* the value is already there *)
+  | Value _ -> () (* the value is already there *)
diff --git a/stdlib/camlinternalOO.ml b/stdlib/camlinternalOO.ml
index 0e296890..0188c148 100644
--- a/stdlib/camlinternalOO.ml
+++ b/stdlib/camlinternalOO.ml
@@ -457,20 +457,20 @@ let lookup_tables root keys =
 
 (**** builtin methods ****)
 
-let get_const x = ret (fun obj -> x)
+let get_const x = ret (fun _obj -> x)
 let get_var n   = ret (fun obj -> Array.unsafe_get obj n)
 let get_env e n =
   ret (fun obj ->
     Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n)
 let get_meth n  = ret (fun obj -> sendself obj n)
 let set_var n   = ret (fun obj x -> Array.unsafe_set obj n x)
-let app_const f x = ret (fun obj -> f x)
+let app_const f x = ret (fun _obj -> f x)
 let app_var f n   = ret (fun obj -> f (Array.unsafe_get obj n))
 let app_env f e n =
   ret (fun obj ->
     f (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n))
 let app_meth f n  = ret (fun obj -> f (sendself obj n))
-let app_const_const f x y = ret (fun obj -> f x y)
+let app_const_const f x y = ret (fun _obj -> f x y)
 let app_const_var f x n   = ret (fun obj -> f x (Array.unsafe_get obj n))
 let app_const_meth f x n = ret (fun obj -> f x (sendself obj n))
 let app_var_const f n x = ret (fun obj -> f (Array.unsafe_get obj n) x)
diff --git a/stdlib/char.ml b/stdlib/char.ml
index f3769b74..fb7660d0 100644
--- a/stdlib/char.ml
+++ b/stdlib/char.ml
@@ -21,9 +21,10 @@ external unsafe_chr: int -> char = "%identity"
 let chr n =
   if n < 0 || n > 255 then invalid_arg "Char.chr" else unsafe_chr n
 
-external string_create: int -> string = "caml_create_string"
-external string_unsafe_set : string -> int -> char -> unit
-                           = "%string_unsafe_set"
+external bytes_create: int -> bytes = "caml_create_bytes"
+external bytes_unsafe_set : bytes -> int -> char -> unit
+                           = "%bytes_unsafe_set"
+external unsafe_to_string : bytes -> string = "%bytes_to_string"
 
 let escaped = function
   | '\'' -> "\\'"
@@ -33,17 +34,17 @@ let escaped = function
   | '\r' -> "\\r"
   | '\b' -> "\\b"
   | ' ' .. '~' as c ->
-      let s = string_create 1 in
-      string_unsafe_set s 0 c;
-      s
+      let s = bytes_create 1 in
+      bytes_unsafe_set s 0 c;
+      unsafe_to_string s
   | c ->
       let n = code c in
-      let s = string_create 4 in
-      string_unsafe_set s 0 '\\';
-      string_unsafe_set s 1 (unsafe_chr (48 + n / 100));
-      string_unsafe_set s 2 (unsafe_chr (48 + (n / 10) mod 10));
-      string_unsafe_set s 3 (unsafe_chr (48 + n mod 10));
-      s
+      let s = bytes_create 4 in
+      bytes_unsafe_set s 0 '\\';
+      bytes_unsafe_set s 1 (unsafe_chr (48 + n / 100));
+      bytes_unsafe_set s 2 (unsafe_chr (48 + (n / 10) mod 10));
+      bytes_unsafe_set s 3 (unsafe_chr (48 + n mod 10));
+      unsafe_to_string s
 
 let lowercase c =
   if (c >= 'A' && c <= 'Z')
diff --git a/stdlib/ephemeron.ml b/stdlib/ephemeron.ml
index 5cec3284..64b2529a 100644
--- a/stdlib/ephemeron.ml
+++ b/stdlib/ephemeron.ml
@@ -189,7 +189,7 @@ module GenHashTable = struct
               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 *)
+                      H.equal and H.get_data *)
                   find_rec key hkey rest
               | Some d -> d
               end
@@ -256,7 +256,7 @@ module GenHashTable = struct
           | ETrue -> true
           | EFalse | EDead -> mem_in_bucket rest
           end
-      | Cons(hk, c, rest) -> mem_in_bucket rest in
+      | Cons(_hk, _c, rest) -> mem_in_bucket rest in
       mem_in_bucket h.data.(key_index h hkey)
 
     let iter f h =
@@ -402,7 +402,7 @@ module K1 = struct
       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 *)
+            the physical equality *)
         match get_key c with
         | None -> GenHashTable.EDead
         | Some k' ->
@@ -421,7 +421,7 @@ module K1 = struct
     include MakeSeeded(struct
         type t = H.t
         let equal = H.equal
-        let hash (seed: int) x = H.hash x
+        let hash (_seed: int) x = H.hash x
       end)
     let create sz = create ~random:false sz
   end
@@ -504,12 +504,12 @@ module K2 = struct
         (struct
           type t = H1.t
           let equal = H1.equal
-          let hash (seed: int) x = H1.hash x
+          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
+          let hash (_seed: int) x = H2.hash x
         end)
     let create sz = create ~random:false sz
   end
@@ -609,7 +609,7 @@ module Kn = struct
     include MakeSeeded(struct
         type t = H.t
         let equal = H.equal
-        let hash (seed: int) x = H.hash x
+        let hash (_seed: int) x = H.hash x
       end)
     let create sz = create ~random:false sz
   end
diff --git a/stdlib/ephemeron.mli b/stdlib/ephemeron.mli
index 1d931192..a05306bf 100644
--- a/stdlib/ephemeron.mli
+++ b/stdlib/ephemeron.mli
@@ -44,7 +44,7 @@
     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 ephemeron
+    reason and in that case the GC will not free it, but the ephemeron
     will not hold the data anymore.
 
     The ephemerons complicate the notion of liveness of values, because
@@ -222,13 +222,13 @@ module K2 : sig
   val check_key2: ('k1,'k2,'d) t -> bool
   (** Same as {!Ephemeron.K1.check_key} *)
 
-  val blit_key1  : ('k1,_,_) t -> ('k1,_,_) t -> unit
+  val blit_key1: ('k1,_,_) t -> ('k1,_,_) t -> unit
   (** Same as {!Ephemeron.K1.blit_key} *)
 
-  val blit_key2  : (_,'k2,_) t -> (_,'k2,_) t -> unit
+  val blit_key2: (_,'k2,_) t -> (_,'k2,_) t -> unit
   (** Same as {!Ephemeron.K1.blit_key} *)
 
-  val blit_key12 : ('k1,'k2,_) t -> ('k1,'k2,_) t -> unit
+  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
@@ -286,7 +286,7 @@ module Kn : sig
   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
+  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
diff --git a/stdlib/filename.ml b/stdlib/filename.ml
index 3e727fba..f9b0bc6c 100644
--- a/stdlib/filename.ml
+++ b/stdlib/filename.ml
@@ -130,7 +130,7 @@ module Win32 = struct
         match s.[i] with
         | '\"' -> add_bs (2*n+1); Buffer.add_char b '\"'; loop (i+1);
         | '\\' -> loop_bs (n+1) (i+1);
-        | c    -> add_bs n; loop i
+        | _    -> add_bs n; loop i
       end
     and add_bs n = for _j = 1 to n do Buffer.add_char b '\\'; done
     in
@@ -151,7 +151,7 @@ module Win32 = struct
     let dir = generic_dirname is_dir_sep current_dir_name path in
     drive ^ dir
   let basename s =
-    let (drive, path) = drive_and_path s in
+    let (_drive, path) = drive_and_path s in
     generic_basename is_dir_sep current_dir_name path
 end
 
@@ -173,11 +173,6 @@ let (current_dir_name, parent_dir_name, dir_sep, is_dir_sep,
      is_relative, is_implicit, check_suffix, temp_dir_name, quote, basename,
      dirname) =
   match Sys.os_type with
-    "Unix" ->
-      (Unix.current_dir_name, Unix.parent_dir_name, Unix.dir_sep,
-       Unix.is_dir_sep,
-       Unix.is_relative, Unix.is_implicit, Unix.check_suffix,
-       Unix.temp_dir_name, Unix.quote, Unix.basename, Unix.dirname)
   | "Win32" ->
       (Win32.current_dir_name, Win32.parent_dir_name, Win32.dir_sep,
        Win32.is_dir_sep,
@@ -188,7 +183,11 @@ let (current_dir_name, parent_dir_name, dir_sep, is_dir_sep,
        Cygwin.is_dir_sep,
        Cygwin.is_relative, Cygwin.is_implicit, Cygwin.check_suffix,
        Cygwin.temp_dir_name, Cygwin.quote, Cygwin.basename, Cygwin.dirname)
-  | _ -> assert false
+  | _ -> (* normally "Unix" *)
+      (Unix.current_dir_name, Unix.parent_dir_name, Unix.dir_sep,
+       Unix.is_dir_sep,
+       Unix.is_relative, Unix.is_implicit, Unix.check_suffix,
+       Unix.temp_dir_name, Unix.quote, Unix.basename, Unix.dirname)
 
 let concat dirname filename =
   let l = String.length dirname in
@@ -200,13 +199,32 @@ let chop_suffix name suff =
   let n = String.length name - String.length suff in
   if n < 0 then invalid_arg "Filename.chop_suffix" else String.sub name 0 n
 
-let chop_extension name =
+let extension_len name =
+  let rec check i0 i =
+    if i < 0 || is_dir_sep name i then 0
+    else if name.[i] = '.' then check i0 (i - 1)
+    else String.length name - i0
+  in
   let rec search_dot i =
-    if i < 0 || is_dir_sep name i then invalid_arg "Filename.chop_extension"
-    else if name.[i] = '.' then String.sub name 0 i
-    else search_dot (i - 1) in
+    if i < 0 || is_dir_sep name i then 0
+    else if name.[i] = '.' then check i (i - 1)
+    else search_dot (i - 1)
+  in
   search_dot (String.length name - 1)
 
+let extension name =
+  let l = extension_len name in
+  if l = 0 then "" else String.sub name (String.length name - l) l
+
+let chop_extension name =
+  let l = extension_len name in
+  if l = 0 then invalid_arg "Filename.chop_extension"
+  else String.sub name 0 (String.length name - l)
+
+let remove_extension name =
+  let l = extension_len name in
+  if l = 0 then name else String.sub name 0 (String.length name - l)
+
 external open_desc: string -> open_flag list -> int -> int = "caml_sys_open"
 external close_desc: int -> unit = "caml_sys_close"
 
diff --git a/stdlib/filename.mli b/stdlib/filename.mli
index b5d11c3d..fa6f0369 100644
--- a/stdlib/filename.mli
+++ b/stdlib/filename.mli
@@ -49,13 +49,37 @@ val chop_suffix : string -> string -> string
    the filename [name]. The behavior is undefined if [name] does not
    end with the suffix [suff]. *)
 
+val extension : string -> string
+(** [extension name] is the shortest suffix [ext] of [name0] where:
+
+    - [name0] is the longest suffix of [name] that does not
+      contain a directory separator;
+    - [ext] starts with a period;
+    - [ext] is preceded by at least one non-period character
+      in [name0].
+
+    If such a suffix does not exist, [extension name] is the empty
+    string.
+
+    @since 4.04
+*)
+
+val remove_extension : string -> string
+(** Return the given file name without its extension, as defined
+    in {!Filename.extension}. If the extension is empty, the function
+    returns the given file name.
+
+    The following invariant holds for any file name [s]:
+
+    [remove_extension s ^ extension s = s]
+
+    @since 4.04
+*)
+
 val chop_extension : string -> string
-(** Return the given file name without its extension. The extension
-   is the shortest suffix starting with a period and not including
-   a directory separator, [.xyz] for instance.
+(** Same as {!Filename.remove_extension}, but raise [Invalid_argument]
+    if the given name has an empty extension. *)
 
-   Raise [Invalid_argument] if the given name does not contain
-   an extension. *)
 
 val basename : string -> string
 (** Split a file name into directory name / base file name.
diff --git a/stdlib/format.ml b/stdlib/format.ml
index 488b0a09..8caa18f5 100644
--- a/stdlib/format.ml
+++ b/stdlib/format.ml
@@ -83,12 +83,10 @@ and tbox = Pp_tbox of int list ref  (* Tabulation box *)
 (* The pretty-printer queue: polymorphic queue definition. *)
 type 'a queue_elem =
   | Nil
-  | Cons of 'a queue_cell
-
-and 'a queue_cell = {
-  mutable head : 'a;
-  mutable tail : 'a queue_elem;
-}
+  | Cons of {
+      head : 'a;
+      mutable tail : 'a queue_elem;
+    }
 
 
 type 'a queue = {
@@ -898,6 +896,9 @@ let pp_get_formatter_output_functions state () =
   (state.pp_out_string, state.pp_out_flush)
 
 
+let pp_flush_formatter state =
+  pp_flush_queue state false
+
 (* The default function to output new lines. *)
 let display_newline state () = state.pp_out_string "\n" 0  1
 
diff --git a/stdlib/format.mli b/stdlib/format.mli
index 1278d358..2f52dbe6 100644
--- a/stdlib/format.mli
+++ b/stdlib/format.mli
@@ -271,13 +271,13 @@ val set_ellipsis_text : string -> unit
 val get_ellipsis_text : unit -> string
 (** Return the text of the ellipsis. *)
 
-(** {6:tags Semantics Tags} *)
+(** {6:tags Semantic Tags} *)
 
 type tag = string
 
-(** {i Semantics tags} (or simply {e tags}) are used to decorate printed
+(** {i Semantic tags} (or simply {e tags}) are used to decorate printed
   entities for user's defined purposes, e.g. setting font and giving size
-  indications for a display device, or marking delimitation of semantics
+  indications for a display device, or marking delimitation of semantic
   entities (e.g. HTML or TeX elements or terminal escape sequences).
 
   By default, those tags do not influence line splitting calculation:
@@ -310,7 +310,7 @@ type tag = string
   corresponding to tag markers is considered as zero for line
   splitting). In addition, advanced users may take advantage of
   the specificity of tag markers to be precisely output when the
-  pretty printer has already decided where to splitt the lines, and
+  pretty printer has already decided where to split the lines, and
   precisely when the queue is flushed into the output device.
 
   In the spirit of HTML tags, the default tag marking functions
@@ -411,7 +411,7 @@ val get_formatter_out_functions : unit -> formatter_out_functions
   including line splitting and indentation functions. Useful to record the
   current setting and restore it afterwards. *)
 
-(** {6:tagsmeaning Changing the meaning of printing semantics tags} *)
+(** {6:tagsmeaning Changing the meaning of printing semantic tags} *)
 
 type formatter_tag_functions = {
   mark_open_tag : tag -> string;
@@ -565,6 +565,14 @@ val pp_get_formatter_out_functions :
    evaluation of these primitives. For instance,
    [print_string] is equal to [pp_print_string std_formatter]. *)
 
+val pp_flush_formatter : formatter -> unit
+(** [pp_flush_formatter fmt] flushes [fmt]'s internal queue, ensuring that all
+    the printing and flushing actions have been performed. In addition, this
+    operation will close all boxes and reset the state of the formatter.
+
+    This will not flush [fmt]'s output. In most cases, the user may want to use
+    {!pp_print_flush} instead. *)
+
 (** {6 Convenience formatting functions.} *)
 
 val pp_print_list:
diff --git a/stdlib/gc.ml b/stdlib/gc.ml
index 5635f438..fc04b606 100644
--- a/stdlib/gc.ml
+++ b/stdlib/gc.ml
@@ -46,6 +46,8 @@ type control = {
 external stat : unit -> stat = "caml_gc_stat"
 external quick_stat : unit -> stat = "caml_gc_quick_stat"
 external counters : unit -> (float * float * float) = "caml_gc_counters"
+external minor_words : unit -> (float [@unboxed])
+  = "caml_gc_minor_words" "caml_gc_minor_words_unboxed" [@@noalloc]
 external get : unit -> control = "caml_gc_get"
 external set : control -> unit = "caml_gc_set"
 external minor : unit -> unit = "caml_gc_minor"
@@ -90,6 +92,8 @@ let allocated_bytes () =
 
 
 external finalise : ('a -> unit) -> 'a -> unit = "caml_final_register"
+external finalise_last : (unit -> unit) -> 'a -> unit =
+  "caml_final_register_called_without_value"
 external finalise_release : unit -> unit = "caml_final_release"
 
 
diff --git a/stdlib/gc.mli b/stdlib/gc.mli
index 4a6d12c3..5a1e6272 100644
--- a/stdlib/gc.mli
+++ b/stdlib/gc.mli
@@ -170,6 +170,16 @@ external counters : unit -> float * float * float = "caml_gc_counters"
 (** Return [(minor_words, promoted_words, major_words)].  This function
     is as fast as [quick_stat]. *)
 
+external minor_words : unit -> (float [@unboxed])
+  = "caml_gc_minor_words" "caml_gc_minor_words_unboxed" [@@noalloc]
+(** Number of words allocated in the minor heap since the program was
+    started. This number is accurate in byte-code programs, but only an
+    approximation in programs compiled to native code.
+
+    In native code this function does not allocate.
+
+    @since 4.04 *)
+
 external get : unit -> control = "caml_gc_get"
 (** Return the current values of the GC parameters in a [control] record. *)
 
@@ -210,18 +220,24 @@ val allocated_bytes : unit -> float
    with [int] on 32-bit machines. *)
 
 external get_minor_free : unit -> int = "caml_get_minor_free" [@@noalloc]
-(** Return the current size of the free space inside the minor heap. *)
+(** Return the current size of the free space inside the minor heap.
+
+    @since 4.03.0 *)
 
 external get_bucket : int -> int = "caml_get_major_bucket" [@@noalloc]
 (** [get_bucket n] returns the current size of the [n]-th future bucket
     of the GC smoothing system. The unit is one millionth of a full GC.
     Raise [Invalid_argument] if [n] is negative, return 0 if n is larger
-    than the smoothing window. *)
+    than the smoothing window.
+
+    @since 4.03.0 *)
 
 external get_credit : unit -> int = "caml_get_major_credit" [@@noalloc]
 (** [get_credit ()] returns the current size of the "work done in advance"
     counter of the GC smoothing system. The unit is one millionth of a
-    full GC. *)
+    full GC.
+
+    @since 4.03.0 *)
 
 external huge_fallback_count : unit -> int = "caml_gc_huge_fallback_count"
 (** Return the number of times we tried to map huge pages and had to fall
@@ -279,9 +295,14 @@ val finalise : ('a -> unit) -> 'a -> unit
    Some constant values can be heap-allocated but never deallocated
    during the lifetime of the program, for example a list of integer
    constants; this is also implementation-dependent.
-   Note that values of types [float] and ['a lazy] (for any ['a]) are
-   sometimes allocated and sometimes not, so finalising them is unsafe,
-   and [finalise] will also raise [Invalid_argument] for them.
+   Note that values of types [float] are sometimes allocated and
+   sometimes not, so finalising them is unsafe, and [finalise] will
+   also raise [Invalid_argument] for them. Values of type ['a Lazy.t]
+   (for any ['a]) are like [float] in this respect, except that the
+   compiler sometimes optimizes them in a way that prevents [finalise]
+   from detecting them. In this case, it will not raise
+   [Invalid_argument], but you should still avoid calling [finalise]
+   on lazy values.
 
 
    The results of calling {!String.make}, {!Bytes.make}, {!Bytes.create},
@@ -289,6 +310,21 @@ val finalise : ('a -> unit) -> 'a -> unit
    heap-allocated and non-constant except when the length argument is [0].
 *)
 
+val finalise_last : (unit -> unit) -> 'a -> unit
+(** same as {!finalise} except the value is not given as argument. So
+    you can't use the given value for the computation of the
+    finalisation function. The benefit is that the function is called
+    after the value is unreachable for the last time instead of the
+    first time. So contrary to {!finalise} the value will never be
+    reachable again or used again. In particular every weak pointer
+    and ephemeron that contained this value as key or data is unset
+    before running the finalisation function. Moreover the
+    finalisation function attached with `GC.finalise` are always
+    called before the finalisation function attached with `GC.finalise_last`.
+
+    @since 4.04
+*)
+
 val finalise_release : unit -> unit
 (** A finalisation function may call [finalise_release] to tell the
     GC that it can launch the next finalisation function without waiting
diff --git a/stdlib/genlex.ml b/stdlib/genlex.ml
index a5e34f4e..b015bb95 100644
--- a/stdlib/genlex.ml
+++ b/stdlib/genlex.ml
@@ -184,18 +184,18 @@ let make_lexer keywords =
     match Stream.peek strm__ with
       Some '(' -> Stream.junk strm__; maybe_nested_comment strm__
     | Some '*' -> Stream.junk strm__; maybe_end_comment strm__
-    | Some c -> Stream.junk strm__; comment strm__
+    | Some _ -> Stream.junk strm__; comment strm__
     | _ -> raise Stream.Failure
   and maybe_nested_comment (strm__ : _ Stream.t) =
     match Stream.peek strm__ with
       Some '*' -> Stream.junk strm__; let s = strm__ in comment s; comment s
-    | Some c -> Stream.junk strm__; comment strm__
+    | Some _ -> Stream.junk strm__; comment strm__
     | _ -> raise Stream.Failure
   and maybe_end_comment (strm__ : _ Stream.t) =
     match Stream.peek strm__ with
       Some ')' -> Stream.junk strm__; ()
     | Some '*' -> Stream.junk strm__; maybe_end_comment strm__
-    | Some c -> Stream.junk strm__; comment strm__
+    | Some _ -> Stream.junk strm__; comment strm__
     | _ -> raise Stream.Failure
   in
-  fun input -> Stream.from (fun count -> next_token input)
+  fun input -> Stream.from (fun _count -> next_token input)
diff --git a/stdlib/hashbang b/stdlib/hashbang
new file mode 100644
index 00000000..04c9334b
--- /dev/null
+++ b/stdlib/hashbang
@@ -0,0 +1 @@
+#! 
\ No newline at end of file
diff --git a/stdlib/hashtbl.ml b/stdlib/hashtbl.ml
index 955f6384..58e558e2 100644
--- a/stdlib/hashtbl.ml
+++ b/stdlib/hashtbl.ml
@@ -31,12 +31,27 @@ type ('a, 'b) t =
   { mutable size: int;                        (* number of entries *)
     mutable data: ('a, 'b) bucketlist array;  (* the buckets *)
     mutable seed: int;                        (* for randomization *)
-    initial_size: int;                        (* initial array size *)
+    mutable initial_size: int;                (* initial array size *)
   }
 
 and ('a, 'b) bucketlist =
     Empty
-  | Cons of 'a * 'b * ('a, 'b) bucketlist
+  | Cons of { mutable key: 'a;
+              mutable data: 'b;
+              mutable next: ('a, 'b) bucketlist }
+
+(* The sign of initial_size encodes the fact that a traversal is
+   ongoing or not.
+
+   This disables the efficient in place implementation of resizing.
+*)
+
+let ongoing_traversal h =
+  Obj.size (Obj.repr h) < 4 (* compatibility with old hash tables *)
+  || h.initial_size < 0
+
+let flip_ongoing_traversal h =
+  h.initial_size <- - h.initial_size
 
 (* To pick random seeds if requested *)
 
@@ -75,14 +90,31 @@ let clear h =
 let reset h =
   let len = Array.length h.data in
   if Obj.size (Obj.repr h) < 4 (* compatibility with old hash tables *)
-    || len = h.initial_size then
+    || len = abs h.initial_size then
     clear h
   else begin
     h.size <- 0;
-    h.data <- Array.make h.initial_size Empty
+    h.data <- Array.make (abs h.initial_size) Empty
   end
 
-let copy h = { h with data = Array.copy h.data }
+let copy_bucketlist = function
+  | Empty -> Empty
+  | Cons {key; data; next} ->
+      let rec loop prec = function
+        | Empty -> ()
+        | Cons {key; data; next} ->
+            let r = Cons {key; data; next} in
+            begin match prec with
+            | Empty -> assert false
+            | Cons prec ->  prec.next <- r
+            end;
+            loop r next
+      in
+      let r = Cons {key; data; next} in
+      loop r next;
+      r
+
+let copy h = { h with data = Array.map copy_bucketlist h.data }
 
 let length h = h.size
 
@@ -92,16 +124,33 @@ let resize indexfun h =
   let nsize = osize * 2 in
   if nsize < Sys.max_array_length then begin
     let ndata = Array.make nsize Empty in
+    let ndata_tail = Array.make nsize Empty in
+    let inplace = not (ongoing_traversal h) in
     h.data <- ndata;          (* so that indexfun sees the new bucket count *)
     let rec insert_bucket = function
-        Empty -> ()
-      | Cons(key, data, rest) ->
-          insert_bucket rest; (* preserve original order of elements *)
+      | Empty -> ()
+      | Cons {key; data; next} as cell ->
+          let cell =
+            if inplace then cell
+            else Cons {key; data; next = Empty}
+          in
           let nidx = indexfun h key in
-          ndata.(nidx) <- Cons(key, data, ndata.(nidx)) in
+          begin match ndata_tail.(nidx) with
+          | Empty -> ndata.(nidx) <- cell;
+          | Cons tail -> tail.next <- cell;
+          end;
+          ndata_tail.(nidx) <- cell;
+          insert_bucket next
+    in
     for i = 0 to osize - 1 do
       insert_bucket odata.(i)
-    done
+    done;
+    if inplace then
+      for i = 0 to nsize - 1 do
+        match ndata_tail.(i) with
+        | Empty -> ()
+        | Cons tail -> tail.next <- Empty
+      done;
   end
 
 let key_index h key =
@@ -110,117 +159,155 @@ let key_index h key =
   then (seeded_hash_param 10 100 h.seed key) land (Array.length h.data - 1)
   else (old_hash_param 10 100 key) mod (Array.length h.data)
 
-let add h key info =
+let add h key data =
   let i = key_index h key in
-  let bucket = Cons(key, info, h.data.(i)) in
+  let bucket = Cons{key; data; next=h.data.(i)} in
   h.data.(i) <- bucket;
   h.size <- h.size + 1;
   if h.size > Array.length h.data lsl 1 then resize key_index h
 
+let rec remove_bucket h i key prec = function
+  | Empty ->
+      ()
+  | (Cons {key=k; next}) as c ->
+      if compare k key = 0
+      then begin
+        h.size <- h.size - 1;
+        match prec with
+        | Empty -> h.data.(i) <- next
+        | Cons c -> c.next <- next
+      end
+      else remove_bucket h i key c next
+
 let remove h key =
-  let rec remove_bucket = function
-    | Empty ->
-        Empty
-    | Cons(k, i, next) ->
-        if compare k key = 0
-        then begin h.size <- h.size - 1; next end
-        else Cons(k, i, remove_bucket next) in
   let i = key_index h key in
-  h.data.(i) <- remove_bucket h.data.(i)
+  remove_bucket h i key Empty h.data.(i)
 
 let rec find_rec key = function
   | Empty ->
       raise Not_found
-  | Cons(k, d, rest) ->
-      if compare key k = 0 then d else find_rec key rest
+  | Cons{key=k; data; next} ->
+      if compare key k = 0 then data else find_rec key next
 
 let find h key =
   match h.data.(key_index h key) with
   | Empty -> raise Not_found
-  | Cons(k1, d1, rest1) ->
+  | Cons{key=k1; data=d1; next=next1} ->
       if compare key k1 = 0 then d1 else
-      match rest1 with
+      match next1 with
       | Empty -> raise Not_found
-      | Cons(k2, d2, rest2) ->
+      | Cons{key=k2; data=d2; next=next2} ->
           if compare key k2 = 0 then d2 else
-          match rest2 with
+          match next2 with
           | Empty -> raise Not_found
-          | Cons(k3, d3, rest3) ->
-              if compare key k3 = 0 then d3 else find_rec key rest3
+          | Cons{key=k3; data=d3; next=next3} ->
+              if compare key k3 = 0 then d3 else find_rec key next3
 
 let find_all h key =
   let rec find_in_bucket = function
   | Empty ->
       []
-  | Cons(k, d, rest) ->
+  | Cons{key=k; data; next} ->
       if compare k key = 0
-      then d :: find_in_bucket rest
-      else find_in_bucket rest in
+      then data :: find_in_bucket next
+      else find_in_bucket next in
   find_in_bucket h.data.(key_index h key)
 
-let replace h key info =
-  let rec replace_bucket = function
-    | Empty ->
-        raise_notrace Not_found
-    | Cons(k, i, next) ->
-        if compare k key = 0
-        then Cons(key, info, next)
-        else Cons(k, i, replace_bucket next) in
+let rec replace_bucket key data = function
+  | Empty ->
+      true
+  | Cons ({key=k; next} as slot) ->
+      if compare k key = 0
+      then (slot.key <- key; slot.data <- data; false)
+      else replace_bucket key data next
+
+let replace h key data =
   let i = key_index h key in
   let l = h.data.(i) in
-  try
-    h.data.(i) <- replace_bucket l
-  with Not_found ->
-    h.data.(i) <- Cons(key, info, l);
+  if replace_bucket key data l then begin
+    h.data.(i) <- Cons{key; data; next=l};
     h.size <- h.size + 1;
     if h.size > Array.length h.data lsl 1 then resize key_index h
+  end
 
 let mem h key =
   let rec mem_in_bucket = function
   | Empty ->
       false
-  | Cons(k, d, rest) ->
-      compare k key = 0 || mem_in_bucket rest in
+  | Cons{key=k; next} ->
+      compare k key = 0 || mem_in_bucket next in
   mem_in_bucket h.data.(key_index h key)
 
 let iter f h =
   let rec do_bucket = function
     | Empty ->
         ()
-    | Cons(k, d, rest) ->
-        f k d; do_bucket rest in
-  let d = h.data in
-  for i = 0 to Array.length d - 1 do
-    do_bucket d.(i)
-  done
+    | Cons{key; data; next} ->
+        f key data; do_bucket next in
+  let old_trav = ongoing_traversal h in
+  if not old_trav then flip_ongoing_traversal h;
+  try
+    let d = h.data in
+    for i = 0 to Array.length d - 1 do
+      do_bucket d.(i)
+    done;
+    if not old_trav then flip_ongoing_traversal h;
+  with exn when not old_trav ->
+    flip_ongoing_traversal h;
+    raise exn
+
+let rec filter_map_inplace_bucket f h i prec = function
+  | Empty ->
+      begin match prec with
+      | Empty -> h.data.(i) <- Empty
+      | Cons c -> c.next <- Empty
+      end
+  | (Cons ({key; data; next} as c)) as slot ->
+      begin match f key data with
+      | None ->
+          h.size <- h.size - 1;
+          filter_map_inplace_bucket f h i prec next
+      | Some data ->
+          begin match prec with
+          | Empty -> h.data.(i) <- slot
+          | Cons c -> c.next <- slot
+          end;
+          c.data <- data;
+          filter_map_inplace_bucket f h i slot next
+      end
 
 let filter_map_inplace f h =
-  let rec do_bucket = function
-    | Empty ->
-        Empty
-    | Cons(k, d, rest) ->
-        match f k d with
-        | None -> h.size <- h.size - 1; 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 old_trav = ongoing_traversal h in
+  if not old_trav then flip_ongoing_traversal h;
+  try
+    for i = 0 to Array.length d - 1 do
+      filter_map_inplace_bucket f h i Empty h.data.(i)
+    done
+  with exn when not old_trav ->
+    flip_ongoing_traversal h;
+    raise exn
 
 let fold f h init =
   let rec do_bucket b accu =
     match b with
       Empty ->
         accu
-    | Cons(k, d, rest) ->
-        do_bucket rest (f k d 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
+    | Cons{key; data; next} ->
+        do_bucket next (f key data accu) in
+  let old_trav = ongoing_traversal h in
+  if not old_trav then flip_ongoing_traversal h;
+  try
+    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;
+    if not old_trav then flip_ongoing_traversal h;
+    !accu
+  with exn when not old_trav ->
+    flip_ongoing_traversal h;
+    raise exn
 
 type statistics = {
   num_bindings: int;
@@ -231,7 +318,7 @@ type statistics = {
 
 let rec bucket_length accu = function
   | Empty -> accu
-  | Cons(_, _, rest) -> bucket_length (accu + 1) rest
+  | Cons{next} -> bucket_length (accu + 1) next
 
 let stats h =
   let mbl =
@@ -318,77 +405,83 @@ module MakeSeeded(H: SeededHashedType): (SeededS with type key = H.t) =
     let key_index h key =
       (H.hash h.seed key) land (Array.length h.data - 1)
 
-    let add h key info =
+    let add h key data =
       let i = key_index h key in
-      let bucket = Cons(key, info, h.data.(i)) in
+      let bucket = Cons{key; data; next=h.data.(i)} in
       h.data.(i) <- bucket;
       h.size <- h.size + 1;
       if h.size > Array.length h.data lsl 1 then resize key_index h
 
+    let rec remove_bucket h i key prec = function
+      | Empty ->
+          ()
+      | (Cons {key=k; next}) as c ->
+          if H.equal k key
+          then begin
+            h.size <- h.size - 1;
+            match prec with
+            | Empty -> h.data.(i) <- next
+            | Cons c -> c.next <- next
+          end
+          else remove_bucket h i key c next
+
     let remove h key =
-      let rec remove_bucket = function
-        | Empty ->
-            Empty
-        | Cons(k, i, next) ->
-            if H.equal k key
-            then begin h.size <- h.size - 1; next end
-            else Cons(k, i, remove_bucket next) in
       let i = key_index h key in
-      h.data.(i) <- remove_bucket h.data.(i)
+      remove_bucket h i key Empty h.data.(i)
 
     let rec find_rec key = function
       | Empty ->
           raise Not_found
-      | Cons(k, d, rest) ->
-          if H.equal key k then d else find_rec key rest
+      | Cons{key=k; data; next} ->
+          if H.equal key k then data else find_rec key next
 
     let find h key =
       match h.data.(key_index h key) with
       | Empty -> raise Not_found
-      | Cons(k1, d1, rest1) ->
+      | Cons{key=k1; data=d1; next=next1} ->
           if H.equal key k1 then d1 else
-          match rest1 with
+          match next1 with
           | Empty -> raise Not_found
-          | Cons(k2, d2, rest2) ->
+          | Cons{key=k2; data=d2; next=next2} ->
               if H.equal key k2 then d2 else
-              match rest2 with
+              match next2 with
               | Empty -> raise Not_found
-              | Cons(k3, d3, rest3) ->
-                  if H.equal key k3 then d3 else find_rec key rest3
+              | Cons{key=k3; data=d3; next=next3} ->
+                  if H.equal key k3 then d3 else find_rec key next3
 
     let find_all h key =
       let rec find_in_bucket = function
       | Empty ->
           []
-      | Cons(k, d, rest) ->
+      | Cons{key=k; data=d; next} ->
           if H.equal k key
-          then d :: find_in_bucket rest
-          else find_in_bucket rest in
+          then d :: find_in_bucket next
+          else find_in_bucket next in
       find_in_bucket h.data.(key_index h key)
 
-    let replace h key info =
-      let rec replace_bucket = function
-        | Empty ->
-            raise_notrace Not_found
-        | Cons(k, i, next) ->
-            if H.equal k key
-            then Cons(key, info, next)
-            else Cons(k, i, replace_bucket next) in
+    let rec replace_bucket key data = function
+      | Empty ->
+          true
+      | Cons ({key=k; next} as slot) ->
+          if H.equal k key
+          then (slot.key <- key; slot.data <- data; false)
+          else replace_bucket key data next
+
+    let replace h key data =
       let i = key_index h key in
       let l = h.data.(i) in
-      try
-        h.data.(i) <- replace_bucket l
-      with Not_found ->
-        h.data.(i) <- Cons(key, info, l);
+      if replace_bucket key data l then begin
+        h.data.(i) <- Cons{key; data; next=l};
         h.size <- h.size + 1;
         if h.size > Array.length h.data lsl 1 then resize key_index h
+      end
 
     let mem h key =
       let rec mem_in_bucket = function
       | Empty ->
           false
-      | Cons(k, d, rest) ->
-          H.equal k key || mem_in_bucket rest in
+      | Cons{key=k; next} ->
+          H.equal k key || mem_in_bucket next in
       mem_in_bucket h.data.(key_index h key)
 
     let iter = iter
@@ -403,7 +496,7 @@ module Make(H: HashedType): (S with type key = H.t) =
     include MakeSeeded(struct
         type t = H.t
         let equal = H.equal
-        let hash (seed: int) x = H.hash x
+        let hash (_seed: int) x = H.hash x
       end)
     let create sz = create ~random:false sz
   end
diff --git a/stdlib/hashtbl.mli b/stdlib/hashtbl.mli
index 96326ae8..6d9cd00d 100644
--- a/stdlib/hashtbl.mli
+++ b/stdlib/hashtbl.mli
@@ -135,7 +135,8 @@ val filter_map_inplace: ('a -> 'b -> 'b option) -> ('a, 'b) t -> unit
     returns [Some new_val], the binding is update to associate the key
     to [new_val].
 
-    Other comments for {!Hashtbl.iter} apply as well.  *)
+    Other comments for {!Hashtbl.iter} apply as well.
+    @since 4.03.0 *)
 
 val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c
 (** [Hashtbl.fold f tbl init] computes
@@ -243,10 +244,10 @@ val stats : ('a, 'b) t -> statistics
 module type HashedType =
   sig
     type t
-      (** The type of the hashtable keys. *)
+    (** The type of the hashtable keys. *)
 
     val equal : t -> t -> bool
-      (** The equality predicate used to compare keys. *)
+    (** The equality predicate used to compare keys. *)
 
     val hash : t -> int
       (** A hashing function on keys. It must be such that if two keys are
@@ -301,10 +302,10 @@ module Make (H : HashedType) : S with type key = H.t
 module type SeededHashedType =
   sig
     type t
-      (** The type of the hashtable keys. *)
+    (** The type of the hashtable keys. *)
 
     val equal: t -> t -> bool
-      (** The equality predicate used to compare keys. *)
+    (** The equality predicate used to compare keys. *)
 
     val hash: int -> t -> int
       (** A seeded hashing function on keys.  The first argument is
diff --git a/stdlib/header.c b/stdlib/header.c
index 1fd4cd5e..28408a51 100644
--- a/stdlib/header.c
+++ b/stdlib/header.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* The launcher for bytecode executables (if #! is not working) */
 
 #include 
diff --git a/stdlib/headernt.c b/stdlib/headernt.c
index d96747e5..9d4943b2 100644
--- a/stdlib/headernt.c
+++ b/stdlib/headernt.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #define STRICT
 #define WIN32_LEAN_AND_MEAN
 
diff --git a/stdlib/list.ml b/stdlib/list.ml
index d969c57b..c02f5e86 100644
--- a/stdlib/list.ml
+++ b/stdlib/list.ml
@@ -17,7 +17,7 @@
 
 let rec length_aux len = function
     [] -> len
-  | a::l -> length_aux (len + 1) l
+  | _::l -> length_aux (len + 1) l
 
 let length l = length_aux 0 l
 
@@ -25,11 +25,11 @@ let cons a l = a::l
 
 let hd = function
     [] -> failwith "hd"
-  | a::l -> a
+  | a::_ -> a
 
 let tl = function
     [] -> failwith "tl"
-  | a::l -> l
+  | _::l -> l
 
 let nth l n =
   if n < 0 then invalid_arg "List.nth" else
@@ -164,20 +164,20 @@ let rec assq x = function
 
 let rec mem_assoc x = function
   | [] -> false
-  | (a, b) :: l -> compare a x = 0 || mem_assoc x l
+  | (a, _) :: l -> compare a x = 0 || mem_assoc x l
 
 let rec mem_assq x = function
   | [] -> false
-  | (a, b) :: l -> a == x || mem_assq x l
+  | (a, _) :: l -> a == x || mem_assq x l
 
 let rec remove_assoc x = function
   | [] -> []
-  | (a, b as pair) :: l ->
+  | (a, _ as pair) :: l ->
       if compare a x = 0 then l else pair :: remove_assoc x l
 
 let rec remove_assq x = function
   | [] -> []
-  | (a, b as pair) :: l -> if a == x then l else pair :: remove_assq x l
+  | (a, _ as pair) :: l -> if a == x then l else pair :: remove_assq x l
 
 let rec find p = function
   | [] -> raise Not_found
@@ -223,7 +223,7 @@ let rec merge cmp l1 l2 =
 let rec chop k l =
   if k = 0 then l else begin
     match l with
-    | x::t -> chop (k-1) t
+    | _::t -> chop (k-1) t
     | _ -> assert false
   end
 
diff --git a/stdlib/list.mli b/stdlib/list.mli
index 10ea3588..7d12712a 100644
--- a/stdlib/list.mli
+++ b/stdlib/list.mli
@@ -67,8 +67,7 @@ val concat : 'a list list -> 'a list
    (length of the argument + length of the longest sub-list). *)
 
 val flatten : 'a list list -> 'a list
-(** Same as [concat].  Not tail-recursive
-   (length of the argument + length of the longest sub-list). *)
+(** An alias for [concat]. *)
 
 
 (** {6 Iterators} *)
diff --git a/stdlib/map.ml b/stdlib/map.ml
index 6f9293fc..50ebdb3d 100644
--- a/stdlib/map.ml
+++ b/stdlib/map.ml
@@ -128,23 +128,23 @@ module Make(Ord: OrderedType) = struct
     let rec mem x = function
         Empty ->
           false
-      | Node(l, v, d, r, _) ->
+      | Node(l, v, _, r, _) ->
           let c = Ord.compare x v in
           c = 0 || mem x (if c < 0 then l else r)
 
     let rec min_binding = function
         Empty -> raise Not_found
-      | Node(Empty, x, d, r, _) -> (x, d)
-      | Node(l, x, d, r, _) -> min_binding l
+      | Node(Empty, x, d, _, _) -> (x, d)
+      | Node(l, _, _, _, _) -> min_binding l
 
     let rec max_binding = function
         Empty -> raise Not_found
-      | Node(l, x, d, Empty, _) -> (x, d)
-      | Node(l, x, d, r, _) -> max_binding r
+      | Node(_, x, d, Empty, _) -> (x, d)
+      | Node(_, _, _, r, _) -> max_binding r
 
     let rec remove_min_binding = function
         Empty -> invalid_arg "Map.remove_min_elt"
-      | Node(Empty, x, d, r, _) -> r
+      | Node(Empty, _, _, r, _) -> r
       | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r
 
     let merge t1 t2 =
@@ -158,7 +158,7 @@ module Make(Ord: OrderedType) = struct
     let rec remove x = function
         Empty ->
           Empty
-      | (Node(l, v, d, r, h) as t) ->
+      | (Node(l, v, d, r, _) as t) ->
           let c = Ord.compare x v in
           if c = 0 then merge l r
           else if c < 0 then
@@ -213,12 +213,12 @@ module Make(Ord: OrderedType) = struct
 
     let rec add_min_binding k v = function
       | Empty -> singleton k v
-      | Node (l, x, d, r, h) ->
+      | Node (l, x, d, r, _) ->
         bal (add_min_binding k v l) x d r
 
     let rec add_max_binding k v = function
       | Empty -> singleton k v
-      | Node (l, x, d, r, h) ->
+      | Node (l, x, d, r, _) ->
         bal l x d (add_max_binding k v r)
 
     (* Same as create and bal, but no assumptions are made on the
@@ -267,7 +267,7 @@ module Make(Ord: OrderedType) = struct
       | (Node (l1, v1, d1, r1, h1), _) when h1 >= height s2 ->
           let (l2, d2, r2) = split v1 s2 in
           concat_or_join (merge f l1 l2) v1 (f v1 (Some d1) d2) (merge f r1 r2)
-      | (_, Node (l2, v2, d2, r2, h2)) ->
+      | (_, Node (l2, v2, d2, r2, _)) ->
           let (l1, d1, r1) = split v2 s1 in
           concat_or_join (merge f l1 l2) v2 (f v2 d1 (Some d2)) (merge f r1 r2)
       | _ ->
diff --git a/stdlib/marshal.mli b/stdlib/marshal.mli
index 220cf384..671feed7 100644
--- a/stdlib/marshal.mli
+++ b/stdlib/marshal.mli
@@ -137,7 +137,12 @@ val from_channel : in_channel -> 'a
 (** [Marshal.from_channel chan] reads from channel [chan] the
    byte representation of a structured value, as produced by
    one of the [Marshal.to_*] functions, and reconstructs and
-   returns the corresponding value.*)
+   returns the corresponding value.
+
+   It raises [End_of_file] if the function has already reached the
+   end of file when starting to read from the channel, and raises
+   [Failure "input_value: truncated object"] if it reaches the end
+   of file later during the unmarshalling. *)
 
 val from_bytes : bytes -> int -> 'a
 (** [Marshal.from_bytes buff ofs] unmarshals a structured value
diff --git a/stdlib/moreLabels.mli b/stdlib/moreLabels.mli
index e33eb937..9c5ab690 100644
--- a/stdlib/moreLabels.mli
+++ b/stdlib/moreLabels.mli
@@ -158,6 +158,7 @@ module Set : sig
       val equal : t -> t -> bool
       val subset : t -> t -> bool
       val iter : f:(elt -> unit) -> t -> unit
+      val map : f:(elt -> elt) -> t -> t
       val fold : f:(elt -> 'a -> 'a) -> t -> init:'a -> 'a
       val for_all : f:(elt -> bool) -> t -> bool
       val exists : f:(elt -> bool) -> t -> bool
diff --git a/stdlib/obj.ml b/stdlib/obj.ml
index 9990f578..35b3925a 100644
--- a/stdlib/obj.ml
+++ b/stdlib/obj.ml
@@ -20,17 +20,19 @@ type t
 external repr : 'a -> t = "%identity"
 external obj : t -> 'a = "%identity"
 external magic : 'a -> 'b = "%identity"
-external is_block : t -> bool = "caml_obj_is_block"
 external is_int : t -> bool = "%obj_is_int"
+let [@inline always] is_block a = not (is_int a)
 external tag : t -> int = "caml_obj_tag"
 external set_tag : t -> int -> unit = "caml_obj_set_tag"
 external size : t -> int = "%obj_size"
+external reachable_words : t -> int = "caml_obj_reachable_words"
 external field : t -> int -> t = "%obj_field"
 external set_field : t -> int -> t -> unit = "%obj_set_field"
 external array_get: 'a array -> int -> 'a = "%array_safe_get"
 external array_set: 'a array -> int -> 'a -> unit = "%array_safe_set"
-let double_field x i = array_get (obj x : float array) i
-let set_double_field x i v = array_set (obj x : float array) i v
+let [@inline always] double_field x i = array_get (obj x : float array) i
+let [@inline always] set_double_field x i v =
+  array_set (obj x : float array) i v
 external new_block : int -> int -> t = "caml_obj_block"
 external dup : t -> t = "caml_obj_dup"
 external truncate : t -> int -> unit = "caml_obj_truncate"
@@ -77,10 +79,10 @@ let extension_constructor x =
     if (tag name) = string_tag then (obj slot : extension_constructor)
     else invalid_arg "Obj.extension_constructor"
 
-let extension_name (slot : extension_constructor) =
+let [@inline always] extension_name (slot : extension_constructor) =
   (obj (field (repr slot) 0) : string)
 
-let extension_id (slot : extension_constructor) =
+let [@inline always] extension_id (slot : extension_constructor) =
   (obj (field (repr slot) 1) : int)
 
 module Ephemeron = struct
diff --git a/stdlib/obj.mli b/stdlib/obj.mli
index 762abd32..31c2e45f 100644
--- a/stdlib/obj.mli
+++ b/stdlib/obj.mli
@@ -23,10 +23,19 @@ type t
 external repr : 'a -> t = "%identity"
 external obj : t -> 'a = "%identity"
 external magic : 'a -> 'b = "%identity"
-external is_block : t -> bool = "caml_obj_is_block"
+val [@inline always] is_block : t -> bool
 external is_int : t -> bool = "%obj_is_int"
 external tag : t -> int = "caml_obj_tag"
 external size : t -> int = "%obj_size"
+external reachable_words : t -> int = "caml_obj_reachable_words"
+  (**
+     Computes the total size (in words, including the headers) of all
+     heap blocks accessible from the argument.  Statically
+     allocated blocks are excluded.
+
+     @Since 4.04
+  *)
+
 external field : t -> int -> t = "%obj_field"
 
 (** When using flambda:
@@ -47,8 +56,9 @@ external field : t -> int -> t = "%obj_field"
 external set_field : t -> int -> t -> unit = "%obj_set_field"
 external set_tag : t -> int -> unit = "caml_obj_set_tag"
 
-val double_field : t -> int -> float  (* @since 3.11.2 *)
-val set_double_field : t -> int -> float -> unit  (* @since 3.11.2 *)
+val [@inline always] double_field : t -> int -> float  (* @since 3.11.2 *)
+val [@inline always] set_double_field : t -> int -> float -> unit
+  (* @since 3.11.2 *)
 external new_block : int -> int -> t = "caml_obj_block"
 external dup : t -> t = "caml_obj_dup"
 external truncate : t -> int -> unit = "caml_obj_truncate"
@@ -77,8 +87,8 @@ val out_of_heap_tag : int
 val unaligned_tag : int   (* should never happen @since 3.11.0 *)
 
 val extension_constructor : 'a -> extension_constructor
-val extension_name : extension_constructor -> string
-val extension_id : extension_constructor -> int
+val [@inline always] extension_name : extension_constructor -> string
+val [@inline always] extension_id : extension_constructor -> int
 
 (** The following two functions are deprecated.  Use module {!Marshal}
     instead. *)
diff --git a/stdlib/parsing.ml b/stdlib/parsing.ml
index 547fade1..3b779f5c 100644
--- a/stdlib/parsing.ml
+++ b/stdlib/parsing.ml
@@ -124,7 +124,7 @@ let clear_parser() =
   Array.fill env.v_stack 0 env.stacksize (Obj.repr ());
   env.lval <- Obj.repr ()
 
-let current_lookahead_fun = ref (fun (x : Obj.t) -> false)
+let current_lookahead_fun = ref (fun (_ : Obj.t) -> false)
 
 let yyparse tables start lexer lexbuf =
   let rec loop cmd arg =
@@ -208,4 +208,4 @@ let rhs_end n = (rhs_end_pos n).pos_cnum
 let is_current_lookahead tok =
   (!current_lookahead_fun)(Obj.repr tok)
 
-let parse_error (msg : string) = ()
+let parse_error (_ : string) = ()
diff --git a/stdlib/pervasives.ml b/stdlib/pervasives.ml
index 02c3bbf6..a8c6310c 100644
--- a/stdlib/pervasives.ml
+++ b/stdlib/pervasives.ml
@@ -186,12 +186,12 @@ external classify_float : (float [@unboxed]) -> fpclass =
 
 external string_length : string -> int = "%string_length"
 external bytes_length : bytes -> int = "%string_length"
-external bytes_create : int -> bytes = "caml_create_string"
+external bytes_create : int -> bytes = "caml_create_bytes"
 external string_blit : string -> int -> bytes -> int -> int -> unit
                      = "caml_blit_string" [@@noalloc]
 external bytes_blit : bytes -> int -> bytes -> int -> int -> unit
-                        = "caml_blit_string" [@@noalloc]
-external bytes_unsafe_to_string : bytes -> string = "%identity"
+                        = "caml_blit_bytes" [@@noalloc]
+external bytes_unsafe_to_string : bytes -> string = "%bytes_to_string"
 
 let ( ^ ) s1 s2 =
   let l1 = string_length s1 and l2 = string_length s2 in
@@ -317,7 +317,7 @@ let flush_all () =
   in iter (out_channels_list ())
 
 external unsafe_output : out_channel -> bytes -> int -> int -> unit
-                       = "caml_ml_output"
+                       = "caml_ml_output_bytes"
 external unsafe_output_string : out_channel -> string -> int -> int -> unit
                               = "caml_ml_output"
 
@@ -494,7 +494,7 @@ type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6
 
 type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
 
-let string_of_format (Format (fmt, str)) = str
+let string_of_format (Format (_fmt, str)) = str
 
 external format_of_string :
  ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli
index dcc2ba6f..1f5e3628 100644
--- a/stdlib/pervasives.mli
+++ b/stdlib/pervasives.mli
@@ -151,7 +151,7 @@ external __LOC__ : string = "%loc_LOC"
     the file currently being parsed by the compiler, with the standard
     error format of OCaml: "File %S, line %d, characters %d-%d".
     @since 4.02.0
- *)
+*)
 
 external __FILE__ : string = "%loc_FILE"
 (** [__FILE__] returns the name of the file currently being
@@ -163,13 +163,13 @@ external __LINE__ : int = "%loc_LINE"
 (** [__LINE__] returns the line number at which this expression
     appears in the file currently being parsed by the compiler.
     @since 4.02.0
- *)
+*)
 
 external __MODULE__ : string = "%loc_MODULE"
 (** [__MODULE__] returns the module name of the file being
     parsed by the compiler.
     @since 4.02.0
- *)
+*)
 
 external __POS__ : string * int * int * int = "%loc_POS"
 (** [__POS__] returns a tuple [(file,lnum,cnum,enum)], corresponding
@@ -186,7 +186,7 @@ external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC"
     compiler, with the standard error format of OCaml: "File %S, line
     %d, characters %d-%d".
     @since 4.02.0
- *)
+*)
 
 external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE"
 (** [__LINE__ expr] returns a pair [(line, expr)], where [line] is the
diff --git a/stdlib/printexc.ml b/stdlib/printexc.ml
index 05a3e709..1e882f58 100644
--- a/stdlib/printexc.ml
+++ b/stdlib/printexc.ml
@@ -39,8 +39,7 @@ let fields x =
   | 0 -> ""
   | 1 -> ""
   | 2 -> sprintf "(%s)" (field x 1)
-  | n -> sprintf "(%s%s)" (field x 1) (other_fields x 2)
-
+  | _ -> sprintf "(%s%s)" (field x 1) (other_fields x 2)
 
 let to_string x =
   let rec conv = function
@@ -85,27 +84,38 @@ let catch fct arg =
     exit 2
 
 type raw_backtrace_slot
-type raw_backtrace = raw_backtrace_slot array
+type raw_backtrace
 
 external get_raw_backtrace:
   unit -> raw_backtrace = "caml_get_exception_raw_backtrace"
 
 type backtrace_slot =
-  | Known_location of bool   (* is_raise *)
-                    * string (* filename *)
-                    * int    (* line number *)
-                    * int    (* start char *)
-                    * int    (* end char *)
-  | Unknown_location of bool (*is_raise*)
+  | Known_location of {
+      is_raise    : bool;
+      filename    : string;
+      line_number : int;
+      start_char  : int;
+      end_char    : int;
+      is_inline   : bool;
+    }
+  | Unknown_location of {
+      is_raise : bool
+    }
 
 (* to avoid warning *)
-let _ = [Known_location (false, "", 0, 0, 0); Unknown_location false]
+let _ = [Known_location { is_raise = false; filename = "";
+                          line_number = 0; start_char = 0; end_char = 0;
+                          is_inline = false };
+         Unknown_location { is_raise = false }]
 
 external convert_raw_backtrace_slot:
   raw_backtrace_slot -> backtrace_slot = "caml_convert_raw_backtrace_slot"
 
-let convert_raw_backtrace rbckt =
-  try Some (Array.map convert_raw_backtrace_slot rbckt)
+external convert_raw_backtrace:
+  raw_backtrace -> backtrace_slot array = "caml_convert_raw_backtrace"
+
+let convert_raw_backtrace bt =
+  try Some (convert_raw_backtrace bt)
   with Failure _ -> None
 
 let format_backtrace_slot pos slot =
@@ -116,12 +126,16 @@ let format_backtrace_slot pos slot =
       if pos = 0 then "Raised by primitive operation at" else "Called from"
   in
   match slot with
-  | Unknown_location true -> (* compiler-inserted re-raise, skipped *) None
-  | Unknown_location false ->
-      Some (sprintf "%s unknown location" (info false))
-  | Known_location(is_raise, filename, lineno, startchar, endchar) ->
-      Some (sprintf "%s file \"%s\", line %d, characters %d-%d"
-              (info is_raise) filename lineno startchar endchar)
+  | Unknown_location l ->
+      if l.is_raise then
+        (* compiler-inserted re-raise, skipped *) None
+      else
+        Some (sprintf "%s unknown location" (info false))
+  | Known_location l ->
+      Some (sprintf "%s file \"%s\"%s, line %d, characters %d-%d"
+              (info l.is_raise) l.filename
+              (if l.is_inline then " (inlined)" else "")
+              l.line_number l.start_char l.end_char)
 
 let print_exception_backtrace outchan backtrace =
   match backtrace with
@@ -159,8 +173,12 @@ let raw_backtrace_to_string raw_backtrace =
   backtrace_to_string (convert_raw_backtrace raw_backtrace)
 
 let backtrace_slot_is_raise = function
-  | Known_location(is_raise, _, _, _, _) -> is_raise
-  | Unknown_location(is_raise) -> is_raise
+  | Known_location l -> l.is_raise
+  | Unknown_location l -> l.is_raise
+
+let backtrace_slot_is_inline = function
+  | Known_location l -> l.is_inline
+  | Unknown_location _ -> false
 
 type location = {
   filename : string;
@@ -171,13 +189,12 @@ type location = {
 
 let backtrace_slot_location = function
   | Unknown_location _ -> None
-  | Known_location(_is_raise, filename, line_number,
-                   start_char, end_char) ->
+  | Known_location l ->
     Some {
-      filename;
-      line_number;
-      start_char;
-      end_char;
+      filename    = l.filename;
+      line_number = l.line_number;
+      start_char  = l.start_char;
+      end_char    = l.end_char;
     }
 
 let backtrace_slots raw_backtrace =
@@ -204,11 +221,19 @@ module Slot = struct
   type t = backtrace_slot
   let format = format_backtrace_slot
   let is_raise = backtrace_slot_is_raise
+  let is_inline = backtrace_slot_is_inline
   let location = backtrace_slot_location
 end
 
-let raw_backtrace_length bckt = Array.length bckt
-let get_raw_backtrace_slot bckt i = Array.get bckt i
+external raw_backtrace_length :
+  raw_backtrace -> int = "caml_raw_backtrace_length" [@@noalloc]
+
+external get_raw_backtrace_slot :
+  raw_backtrace -> int -> raw_backtrace_slot = "caml_raw_backtrace_slot"
+
+external get_raw_backtrace_next_slot :
+  raw_backtrace_slot -> raw_backtrace_slot option
+  = "caml_raw_backtrace_next_slot"
 
 (* confusingly named:
    returns the *string* corresponding to the global current backtrace *)
diff --git a/stdlib/printexc.mli b/stdlib/printexc.mli
index e6aa6816..19bd39c3 100644
--- a/stdlib/printexc.mli
+++ b/stdlib/printexc.mli
@@ -159,8 +159,8 @@ val set_uncaught_exception_handler: (exn -> raw_backtrace -> unit) -> unit
 
 (** {6 Manipulation of backtrace information}
 
-    Those function allow to traverse the slots of a raw backtrace,
-    extract information from them in a programmer-friendly format.
+    These functions are used to traverse the slots of a raw backtrace
+    and extract information from them in a programmer-friendly format.
 *)
 
 type backtrace_slot
@@ -211,6 +211,14 @@ module Slot : sig
       @since 4.02
   *)
 
+  val is_inline : t -> bool
+  (** [is_inline slot] is [true] when [slot] refers to a call
+      that got inlined by the compiler, and [false] when it comes from
+      any other context.
+
+      @since 4.04.0
+  *)
+
   val location : t -> location option
   (** [location slot] returns the location information of the slot,
       if available, and [None] otherwise.
@@ -277,6 +285,13 @@ val convert_raw_backtrace_slot : raw_backtrace_slot -> backtrace_slot
 *)
 
 
+val get_raw_backtrace_next_slot :
+    raw_backtrace_slot -> raw_backtrace_slot option
+(** [get_raw_backtrace_next_slot slot] returns the next slot inlined, if any.
+
+    @since 4.04.0
+*)
+
 (** {6 Exception slots} *)
 
 val exn_slot_id: exn -> int
diff --git a/stdlib/scanf.ml b/stdlib/scanf.ml
index fd195b2b..7be353a1 100644
--- a/stdlib/scanf.ml
+++ b/stdlib/scanf.ml
@@ -1299,9 +1299,9 @@ fun k ign fmt -> match ign with
    take_format_readers, and aggegate scanned values into an
    heterogeneous list. *)
 (* Return the heterogeneous list of scanned values. *)
-let rec make_scanf : type a c d e f .
+let rec make_scanf : type a c d e f.
     Scanning.in_channel -> (a, Scanning.in_channel, c, d, e, f) fmt ->
-      (d, _) heter_list -> (a, f) heter_list =
+      (d, e) heter_list -> (a, f) heter_list =
 fun ib fmt readers -> match fmt with
   | Char rest ->
     let _ = scan_char 0 ib in
@@ -1368,9 +1368,13 @@ fun ib fmt readers -> match fmt with
   | Custom _ ->
     invalid_arg "scanf: bad conversion \"%?\" (custom converter)"
   | Reader fmt_rest ->
-    let Cons (reader, readers_rest) = readers in
-    let x = reader ib in
-    Cons (x, make_scanf ib fmt_rest readers_rest)
+    begin match readers with
+    | Cons (reader, readers_rest) ->
+        let x = reader ib in
+        Cons (x, make_scanf ib fmt_rest readers_rest)
+    | Nil -> 
+        invalid_arg "scanf: missing reader"
+    end
   | Flush rest ->
     if Scanning.end_of_input ib then make_scanf ib rest readers
     else bad_input "end of input not found"
@@ -1460,7 +1464,7 @@ fun ib fmt readers -> match fmt with
 (* Pass padding and precision to the generic scanner `scan'. *)
 and pad_prec_scanf : type a c d e f x y z t .
     Scanning.in_channel -> (a, Scanning.in_channel, c, d, e, f) fmt ->
-      (d, _) heter_list -> (x, y) padding -> (y, z -> a) precision ->
+      (d, e) heter_list -> (x, y) padding -> (y, z -> a) precision ->
       (int -> int -> Scanning.in_channel -> t) ->
       (Scanning.in_channel -> z) ->
       (x, f) heter_list =
diff --git a/stdlib/set.ml b/stdlib/set.ml
index ebbd0a3a..ac10e564 100644
--- a/stdlib/set.ml
+++ b/stdlib/set.ml
@@ -38,6 +38,7 @@ module type S =
     val equal: t -> t -> bool
     val subset: t -> t -> bool
     val iter: (elt -> unit) -> t -> unit
+    val map: (elt -> elt) -> t -> t
     val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a
     val for_all: (elt -> bool) -> t -> bool
     val exists: (elt -> bool) -> t -> bool
@@ -135,12 +136,12 @@ module Make(Ord: OrderedType) =
 
     let rec add_min_element v = function
       | Empty -> singleton v
-      | Node (l, x, r, h) ->
+      | Node (l, x, r, _h) ->
         bal (add_min_element v l) x r
 
     let rec add_max_element v = function
       | Empty -> singleton v
-      | Node (l, x, r, h) ->
+      | Node (l, x, r, _h) ->
         bal l x (add_max_element v r)
 
     (* Same as create and bal, but no assumptions are made on the
@@ -159,19 +160,19 @@ module Make(Ord: OrderedType) =
 
     let rec min_elt = function
         Empty -> raise Not_found
-      | Node(Empty, v, r, _) -> v
-      | Node(l, v, r, _) -> min_elt l
+      | Node(Empty, v, _, _) -> v
+      | Node(l, _, _, _) -> min_elt l
 
     let rec max_elt = function
         Empty -> raise Not_found
-      | Node(l, v, Empty, _) -> v
-      | Node(l, v, r, _) -> max_elt r
+      | Node(_, v, Empty, _) -> v
+      | Node(_, _, r, _) -> max_elt r
 
     (* Remove the smallest element of the given set *)
 
     let rec remove_min_elt = function
         Empty -> invalid_arg "Set.remove_min_elt"
-      | Node(Empty, v, r, _) -> r
+      | Node(Empty, _, r, _) -> r
       | Node(l, v, r, _) -> bal (remove_min_elt l) v r
 
     (* Merge two trees l and r into one.
@@ -256,8 +257,8 @@ module Make(Ord: OrderedType) =
 
     let rec inter s1 s2 =
       match (s1, s2) with
-        (Empty, t2) -> Empty
-      | (t1, Empty) -> Empty
+        (Empty, _) -> Empty
+      | (_, Empty) -> Empty
       | (Node(l1, v1, r1, _), t2) ->
           match split v1 t2 with
             (l2, false, r2) ->
@@ -267,7 +268,7 @@ module Make(Ord: OrderedType) =
 
     let rec diff s1 s2 =
       match (s1, s2) with
-        (Empty, t2) -> Empty
+        (Empty, _) -> Empty
       | (t1, Empty) -> t1
       | (Node(l1, v1, r1, _), t2) ->
           match split v1 t2 with
@@ -356,7 +357,7 @@ module Make(Ord: OrderedType) =
 
     let rec cardinal = function
         Empty -> 0
-      | Node(l, v, r, _) -> cardinal l + 1 + cardinal r
+      | Node(l, _, r, _) -> cardinal l + 1 + cardinal r
 
     let rec elements_aux accu = function
         Empty -> accu
@@ -374,6 +375,21 @@ module Make(Ord: OrderedType) =
           if c = 0 then v
           else find x (if c < 0 then l else r)
 
+    let rec map f = function
+      | Empty -> Empty
+      | Node (l, v, r, _) as t ->
+         (* enforce left-to-right evaluation order *)
+         let l' = map f l in
+         let v' = f v in
+         let r' = map f r in
+         if l == l' && v == v' && r == r' then t
+         else begin
+             if (l' = Empty || Ord.compare (max_elt l') v < 0)
+                && (r' = Empty || Ord.compare v (min_elt r') < 0)
+             then join l' v' r'
+             else union l' (add v' r')
+         end
+
     let of_sorted_list l =
       let rec sub n l =
         match n, l with
diff --git a/stdlib/set.mli b/stdlib/set.mli
index 5d968e0c..f57999eb 100644
--- a/stdlib/set.mli
+++ b/stdlib/set.mli
@@ -118,6 +118,17 @@ module type S =
        The elements of [s] are presented to [f] in increasing order
        with respect to the ordering over the type of the elements. *)
 
+    val map: (elt -> elt) -> t -> t
+    (** [map f s] is the set whose elements are [f a0],[f a1]... [f
+        aN], where [a0],[a1]...[aN] are the elements of [s].
+
+       The elements are passed to [f] in increasing order
+       with respect to the ordering over the type of the elements.
+
+       If no element of [s] is changed by [f], [s] is returned
+       unchanged. (If each output of [f] is physically equal to its
+       input, the returned set is physically equal to [s].) *)
+
     val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a
     (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)],
        where [x1 ... xN] are the elements of [s], in increasing order. *)
diff --git a/stdlib/sharpbang b/stdlib/sharpbang
deleted file mode 100644
index 04c9334b..00000000
--- a/stdlib/sharpbang
+++ /dev/null
@@ -1 +0,0 @@
-#! 
\ No newline at end of file
diff --git a/stdlib/spacetime.ml b/stdlib/spacetime.ml
new file mode 100644
index 00000000..56dde7c5
--- /dev/null
+++ b/stdlib/spacetime.ml
@@ -0,0 +1,89 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   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.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+external spacetime_enabled : unit -> bool
+  = "caml_spacetime_enabled" [@@noalloc]
+
+let if_spacetime_enabled f =
+  if spacetime_enabled () then f () else ()
+
+module Series = struct
+  type t = {
+    channel : out_channel;
+    mutable closed : bool;
+  }
+
+  external write_magic_number : out_channel -> unit
+    = "caml_spacetime_only_works_for_native_code"
+      "caml_spacetime_write_magic_number"
+
+  external register_channel_for_spacetime : out_channel -> unit
+    = "caml_register_channel_for_spacetime"
+
+  let create ~path =
+    if spacetime_enabled () then begin
+      let channel = open_out path in
+      register_channel_for_spacetime channel;
+      let t =
+        { channel = channel;
+          closed = false;
+        }
+      in
+      write_magic_number t.channel;
+      t
+    end else begin
+      { channel = stdout;  (* arbitrary value *)
+        closed = true;
+      }
+    end
+
+  external save_event : ?time:float -> out_channel -> event_name:string -> unit
+    = "caml_spacetime_only_works_for_native_code"
+      "caml_spacetime_save_event"
+
+  let save_event ?time t ~event_name =
+    if_spacetime_enabled (fun () ->
+      save_event ?time t.channel ~event_name)
+
+  external save_trie : ?time:float -> out_channel -> unit
+    = "caml_spacetime_only_works_for_native_code"
+      "caml_spacetime_save_trie"
+
+  let save_and_close ?time t =
+    if_spacetime_enabled (fun () ->
+      if t.closed then failwith "Series is closed";
+      save_trie ?time t.channel;
+      close_out t.channel;
+      t.closed <- true)
+end
+
+module Snapshot = struct
+  external take : ?time:float -> out_channel -> unit
+    = "caml_spacetime_only_works_for_native_code"
+      "caml_spacetime_take_snapshot"
+
+  let take ?time { Series.closed; channel } =
+    if_spacetime_enabled (fun () ->
+      if closed then failwith "Series is closed";
+      Gc.minor ();
+      take ?time channel)
+end
+
+external save_event_for_automatic_snapshots : event_name:string -> unit
+  = "caml_spacetime_only_works_for_native_code"
+    "caml_spacetime_save_event_for_automatic_snapshots"
+
+let save_event_for_automatic_snapshots ~event_name =
+  if_spacetime_enabled (fun () ->
+    save_event_for_automatic_snapshots ~event_name)
diff --git a/stdlib/spacetime.mli b/stdlib/spacetime.mli
new file mode 100644
index 00000000..5f3b51e6
--- /dev/null
+++ b/stdlib/spacetime.mli
@@ -0,0 +1,95 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   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.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Profiling of a program's space behaviour over time.
+    Currently only supported on x86-64 platforms running 64-bit code.
+
+    To use the functions in this module you must:
+    - configure the compiler with "-spacetime";
+    - compile to native code.
+    Without these conditions being satisfied the functions in this module
+    will have no effect.
+
+    Instead of manually taking profiling heap snapshots with this module it is
+    possible to use an automatic snapshot facility that writes profiling
+    information at fixed intervals to a file. To enable this, all that needs to
+    be done is to build the relevant program using a compiler configured with
+    -spacetime; and set the environment variable OCAML_SPACETIME_INTERVAL to an
+    integer number of milliseconds giving the interval between profiling heap
+    snapshots. This interval should not be made excessively small relative to
+    the running time of the program. A typical interval to start with might be
+    1/100 of the running time of the program.  The program must exit "normally"
+    (i.e. by calling [exit], with whatever exit code, rather than being
+    abnormally terminated by a signal) so that the snapshot file is
+    correctly completed.
+
+    When using the automatic snapshot mode the profiling output is written
+    to a file called "spacetime-" where  is the process ID of the
+    program.  (If the program forks and continues executing then multiple
+    files may be produced with different pid numbers.)  The profiling output
+    is by default written to the current working directory when the program
+    starts.  This may be customised by setting the OCAML_SPACETIME_SNAPSHOT_DIR
+    environment variable to the name of the desired directory.
+
+    If using automatic snapshots the presence of the
+    [save_event_for_automatic_snapshots] function, below, should be noted.
+
+    The functions in this module are thread safe.
+
+    For functions to decode the information recorded by the profiler,
+    see the Spacetime offline library in otherlibs/. *)
+
+module Series : sig
+  (** Type representing a file that will hold a series of heap snapshots
+      together with additional information required to interpret those
+      snapshots. *)
+  type t
+
+  (** [create ~path] creates a series file at [path]. *)
+  val create : path:string -> t
+
+  (** [save_event] writes an event, which is an arbitrary string, into the
+      given series file.  This may be used for identifying particular points
+      during program execution when analysing the profile.
+      The optional [time] parameter is as for [Snapshot.take].
+  *)
+  val save_event : ?time:float -> t -> event_name:string -> unit
+
+  (** [save_and_close series] writes information into [series] required for
+      interpeting the snapshots that [series] contains and then closes the
+      [series] file. This function must be called to produce a valid series
+      file.
+      The optional [time] parameter is as for [Snapshot.take].
+  *)
+  val save_and_close : ?time:float -> t -> unit
+end
+
+module Snapshot : sig
+  (** [take series] takes a snapshot of the profiling annotations on the values
+      in the minor and major heaps, together with GC stats, and write the
+      result to the [series] file.  This function triggers a minor GC but does
+      not allocate any memory itself.
+      If the optional [time] is specified, it will be used instead of the
+      result of [Sys.time] as the timestamp of the snapshot.  Such [time]s
+      should start from zero and be monotonically increasing.  This parameter
+      is intended to be used so that snapshots can be correlated against wall
+      clock time (which is not supported in the standard library) rather than
+      elapsed CPU time.
+  *)
+  val take : ?time:float -> Series.t -> unit
+end
+
+(** Like [Series.save_event], but writes to the automatic snapshot file.
+    This function is a no-op if OCAML_SPACETIME_INTERVAL was not set. *)
+val save_event_for_automatic_snapshots : event_name:string -> unit
diff --git a/stdlib/stream.ml b/stdlib/stream.ml
index 73c8dfb2..e9b5e611 100644
--- a/stdlib/stream.ml
+++ b/stdlib/stream.ml
@@ -52,8 +52,8 @@ let rec get_data : type v. int -> v data -> v data = fun count d -> match d with
      | Sempty -> get_data count d2
      | _ -> assert false
      end
- | Sgen {curr = Some None; func = _ } -> Sempty
- | Sgen ({curr = Some(Some a); func = f} as g) ->
+ | Sgen {curr = Some None} -> Sempty
+ | Sgen ({curr = Some(Some a)} as g) ->
      g.curr <- None; Scons(a, d)
  | Sgen g ->
      begin match g.func count with
@@ -230,4 +230,4 @@ and dump_data : type v. (v -> unit) -> v data -> unit = fun f ->
       print_string ")"
   | Slazy _ -> print_string "Slazy"
   | Sgen _ -> print_string "Sgen"
-  | Sbuffio b -> print_string "Sbuffio"
+  | Sbuffio _ -> print_string "Sbuffio"
diff --git a/stdlib/string.ml b/stdlib/string.ml
index 7189ce99..9c4a97f2 100644
--- a/stdlib/string.ml
+++ b/stdlib/string.ml
@@ -15,6 +15,12 @@
 
 (* String operations, based on byte sequence operations *)
 
+(* WARNING: Some functions in this file are duplicated in bytes.ml for
+   efficiency reasons. When you modify the one in this file you need to
+   modify its duplicate in bytes.ml.
+   These functions have a "duplicated" comment above their definition.
+*)
+
 external length : string -> int = "%string_length"
 external get : string -> int -> char = "%string_safe_get"
 external set : bytes -> int -> char -> unit = "%string_safe_set"
@@ -44,28 +50,37 @@ let fill =
 let blit =
   B.blit_string
 
-let concat sep l =
-  match l with
-  | [] -> ""
-  | hd :: tl ->
-      let num = ref 0 and len = ref 0 in
-      List.iter (fun s -> incr num; len := !len + length s) l;
-      let r = B.create (!len + length sep * (!num - 1)) in
-      unsafe_blit hd 0 r 0 (length hd);
-      let pos = ref(length hd) in
-      List.iter
-        (fun s ->
-          unsafe_blit sep 0 r !pos (length sep);
-          pos := !pos + length sep;
-          unsafe_blit s 0 r !pos (length s);
-          pos := !pos + length s)
-        tl;
-      Bytes.unsafe_to_string r
+let ensure_ge x y = if x >= y then x else invalid_arg "String.concat"
+
+let rec sum_lengths acc seplen = function
+  | [] -> acc
+  | hd :: [] -> length hd + acc
+  | hd :: tl -> sum_lengths (ensure_ge (length hd + seplen + acc) acc) seplen tl
 
+let rec unsafe_blits dst pos sep seplen = function
+    [] -> dst
+  | hd :: [] ->
+    unsafe_blit hd 0 dst pos (length hd); dst
+  | hd :: tl ->
+    unsafe_blit hd 0 dst pos (length hd);
+    unsafe_blit sep 0 dst (pos + length hd) seplen;
+    unsafe_blits dst (pos + length hd + seplen) sep seplen tl
+
+let concat sep = function
+    [] -> ""
+  | l -> let seplen = length sep in bts @@
+          unsafe_blits 
+            (B.create (sum_lengths 0 seplen l))
+            0 sep seplen l
+
+(* duplicated in bytes.ml *)
 let iter f s =
-  B.iter f (bos s)
+  for i = 0 to length s - 1 do f (unsafe_get s i) done
+
+(* duplicated in bytes.ml *)
 let iteri f s =
-  B.iteri f (bos s)
+  for i = 0 to length s - 1 do f i (unsafe_get s i) done
+
 let map f s =
   B.map f (bos s) |> bts
 let mapi f s =
@@ -98,20 +113,52 @@ let escaped s =
   else
     s
 
-let index s c =
-  B.index (bos s) c
-let rindex s c =
-  B.rindex (bos s) c
-let index_from s i c=
-  B.index_from (bos s) i c
+(* duplicated in bytes.ml *)
+let rec index_rec s lim i c =
+  if i >= lim then raise Not_found else
+  if unsafe_get s i = c then i else index_rec s lim (i + 1) c
+
+(* duplicated in bytes.ml *)
+let index s c = index_rec s (length s) 0 c
+
+(* duplicated in bytes.ml *)
+let index_from s i c =
+  let l = length s in
+  if i < 0 || i > l then invalid_arg "String.index_from / Bytes.index_from" else
+    index_rec s l i c
+
+(* duplicated in bytes.ml *)
+let rec rindex_rec s i c =
+  if i < 0 then raise Not_found else
+  if unsafe_get s i = c then i else rindex_rec s (i - 1) c
+
+(* duplicated in bytes.ml *)
+let rindex s c = rindex_rec s (length s - 1) c
+
+(* duplicated in bytes.ml *)
 let rindex_from s i c =
-  B.rindex_from (bos s) i c
-let contains s c =
-  B.contains (bos s) c
+  if i < -1 || i >= length s then
+    invalid_arg "String.rindex_from / Bytes.rindex_from"
+  else
+    rindex_rec s i c
+
+(* duplicated in bytes.ml *)
 let contains_from s i c =
-  B.contains_from (bos s) i c
+  let l = length s in
+  if i < 0 || i > l then
+    invalid_arg "String.contains_from / Bytes.contains_from"
+  else
+    try ignore (index_rec s l i c); true with Not_found -> false
+
+(* duplicated in bytes.ml *)
+let contains s c = contains_from s 0 c
+
+(* duplicated in bytes.ml *)
 let rcontains_from s i c =
-  B.rcontains_from (bos s) i c
+  if i < 0 || i >= length s then
+    invalid_arg "String.rcontains_from / Bytes.rcontains_from"
+  else
+    try ignore (rindex_rec s i c); true with Not_found -> false
 
 let uppercase_ascii s =
   B.uppercase_ascii (bos s) |> bts
@@ -127,6 +174,17 @@ type t = string
 let compare (x: t) (y: t) = Pervasives.compare x y
 external equal : string -> string -> bool = "caml_string_equal"
 
+let split_on_char sep s =
+  let r = ref [] in
+  let j = ref (length s) in
+  for i = length s - 1 downto 0 do
+    if unsafe_get s i = sep then begin
+      r := sub s (i + 1) (!j - i - 1) :: !r;
+      j := i
+    end
+  done;
+  sub s 0 !j :: !r
+
 (* Deprecated functions implemented via other deprecated functions *)
 [@@@ocaml.warning "-3"]
 let uppercase s =
diff --git a/stdlib/string.mli b/stdlib/string.mli
index b7d89565..5c66cd00 100644
--- a/stdlib/string.mli
+++ b/stdlib/string.mli
@@ -282,6 +282,21 @@ val equal: t -> t -> bool
 (** The equal function for strings.
     @since 4.03.0 *)
 
+val split_on_char: char -> string -> string list
+(** [String.split_on_char sep s] returns the list of all (possibly empty)
+    substrings of [s] that are delimited by the [sep] character.
+
+    The function's output is specified by the following invariants:
+
+    - The list is not empty.
+    - Concatenating its elements using [sep] as a separator returns a
+      string equal to the input ([String.concat (String.make 1 sep)
+      (String.split_on_char sep s) = s]).
+    - No string in the result contains the [sep] character.
+
+    @since 4.04.0
+*)
+
 (**/**)
 
 (* The following is for system use only. Do not call directly. *)
diff --git a/stdlib/sys.mli b/stdlib/sys.mli
index e5c69e5e..d2061341 100644
--- a/stdlib/sys.mli
+++ b/stdlib/sys.mli
@@ -86,6 +86,22 @@ val os_type : string
 -  ["Win32"] (for MS-Windows, OCaml compiled with MSVC++ or Mingw),
 -  ["Cygwin"] (for MS-Windows, OCaml compiled with Cygwin). *)
 
+type backend_type =
+  | Native
+  | Bytecode
+  | Other of string (**)
+(** Currently, the official distribution only supports [Native] and
+    [Bytecode], but it can be other backends with alternative
+    compilers, for example, javascript.
+
+    @since 4.04.0
+*)
+
+val backend_type : backend_type
+(** Backend type  currently executing the OCaml program.
+    @ since 4.04.0
+ *)
+
 val unix : bool
 (** True if [Sys.os_type = "Unix"].
     @since 4.01.0 *)
@@ -278,10 +294,14 @@ val enable_runtime_warnings: bool -> unit
 (** Control whether the OCaml runtime system can emit warnings
     on stderr.  Currently, the only supported warning is triggered
     when a channel created by [open_*] functions is finalized without
-    being closed.  Runtime warnings are enabled by default. *)
+    being closed.  Runtime warnings are enabled by default.
+
+    @since 4.03.0 *)
 
 val runtime_warnings_enabled: unit -> bool
-(** Return whether runtime warnings are currently enabled. *)
+(** Return whether runtime warnings are currently enabled.
+
+    @since 4.03.0 *)
 
 (** {6 Optimization} *)
 
@@ -298,4 +318,6 @@ external opaque_identity : 'a -> 'a = "%opaque"
         ignore (Sys.opaque_identity (my_pure_computation ()))
       done
     ]}
+
+    @since 4.03.0
 *)
diff --git a/stdlib/sys.mlp b/stdlib/sys.mlp
index d9fec96a..7e79cbd9 100644
--- a/stdlib/sys.mlp
+++ b/stdlib/sys.mlp
@@ -1,3 +1,4 @@
+#2 "stdlib/sys.mlp"
 (**************************************************************************)
 (*                                                                        *)
 (*                                 OCaml                                  *)
@@ -17,6 +18,10 @@
    your changes will be lost.
 *)
 
+type backend_type =
+  | Native
+  | Bytecode
+  | Other of string
 (* System interface *)
 
 external get_config: unit -> string * int * bool = "caml_sys_get_config"
@@ -28,9 +33,11 @@ external max_wosize : unit -> int = "%max_wosize"
 external unix : unit -> bool = "%ostype_unix"
 external win32 : unit -> bool = "%ostype_win32"
 external cygwin : unit -> bool = "%ostype_cygwin"
+external get_backend_type : unit -> backend_type = "%backend_type"
 
 let (executable_name, argv) = get_argv()
 let (os_type, _, _) = get_config()
+let backend_type = get_backend_type ()
 let big_endian = big_endian ()
 let word_size = word_size ()
 let int_size = int_size ()
diff --git a/stdlib/weak.ml b/stdlib/weak.ml
index d2d71576..631c73e0 100644
--- a/stdlib/weak.ml
+++ b/stdlib/weak.ml
@@ -200,7 +200,9 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
     let sz = length bucket in
     let rec loop i =
       if i >= sz then begin
-        let newsz = min (3 * sz / 2 + 3) (Sys.max_array_length - 1) in
+        let newsz =
+          min (3 * sz / 2 + 3) (Sys.max_array_length - additional_values)
+        in
         if newsz <= sz then failwith "Weak.Make: hash bucket cannot grow more";
         let newbucket = weak_create newsz in
         let newhashes = Array.make newsz 0 in
@@ -255,7 +257,8 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
     find_or t d (fun h index -> add_aux t set (Some d) h index; d)
 
 
-  let find t d = find_or t d (fun h index -> raise Not_found)
+  let find t d = find_or t d (fun _h _index -> raise Not_found)
+
 
   let find_shadow t d iffound ifnotfound =
     let h = H.hash d in
@@ -276,7 +279,9 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
 
   let remove t d = find_shadow t d (fun w i -> set w i None) ()
 
-  let mem t d = find_shadow t d (fun w i -> true) false
+
+  let mem t d = find_shadow t d (fun _w _i -> true) false
+
 
   let find_all t d =
     let h = H.hash d in
diff --git a/stdlib/weak.mli b/stdlib/weak.mli
index 64b58c52..95249444 100644
--- a/stdlib/weak.mli
+++ b/stdlib/weak.mli
@@ -105,7 +105,7 @@ val blit : 'a t -> int -> 'a t -> int -> int -> unit
 
 module type S = sig
   type data
-    (** The type of the elements stored in the table. *)
+  (** The type of the elements stored in the table. *)
 
   type t
     (** The type of tables that contain elements of type [data].
@@ -118,7 +118,7 @@ module type S = sig
         size [n].  The table will grow as needed. *)
 
   val clear : t -> unit
-    (** Remove all elements from the table. *)
+  (** Remove all elements from the table. *)
 
   val merge : t -> data -> data
     (** [merge t x] returns an instance of [x] found in [t] if any,
diff --git a/testsuite/Makefile b/testsuite/Makefile
index 48007f34..828272b2 100644
--- a/testsuite/Makefile
+++ b/testsuite/Makefile
@@ -32,6 +32,7 @@ default:
 	@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 "  tools           build test tools"
 	@echo "  clean           delete generated files"
 	@echo "  report          print the report for the last execution"
 	@echo
@@ -40,7 +41,7 @@ default:
 	@echo "(default value = $(MAX_TESTSUITE_DIR_RETRIES))"
 
 .PHONY: all
-all: lib
+all: lib tools
 	@for dir in tests/*; do \
 	  $(MAKE) $(NO_PRINT) exec-one DIR=$$dir; \
 	done 2>&1 | tee _log
@@ -48,7 +49,7 @@ all: lib
 	@$(MAKE) report
 
 .PHONY: all-%
-all-%: lib
+all-%: lib tools
 	@for dir in tests/$**; do \
 	  $(MAKE) $(NO_PRINT) exec-one DIR=$$dir; \
 	done 2>&1 | tee _log
@@ -80,7 +81,7 @@ all-%: lib
 # but the demangling separation is arguably nicer behavior that we might
 # want to implement at the exec-one level to also have it in the 'all' target.
 .PHONY: parallel-%
-parallel-%: lib
+parallel-%: lib tools
 	@echo | parallel >/dev/null 2>/dev/null \
 	 || (echo "Unable to run the GNU parallel tool;";\
 	     echo "You should install it before using the parallel* targets.";\
@@ -100,7 +101,7 @@ parallel-%: lib
 parallel: parallel-*
 
 .PHONY: list
-list: lib
+list: lib tools
 	@if [ -z "$(FILE)" ]; \
 	  then echo "No value set for variable 'FILE'."; \
 	  exit 1; \
@@ -112,7 +113,7 @@ list: lib
 	@$(MAKE) report
 
 .PHONY: one
-one: lib
+one: lib tools
 	@if [ -z "$(DIR)" ]; then \
 	  echo "No value set for variable 'DIR'."; \
 	  exit 1; \
@@ -165,9 +166,14 @@ promote:
 lib:
 	@cd lib && $(MAKE) -s BASEDIR=$(BASEDIR)
 
+.PHONY: tools
+tools:
+	@cd tools && $(MAKE) -s BASEDIR=$(BASEDIR)
+
 .PHONY: clean
 clean:
 	@cd lib && $(MAKE) BASEDIR=$(BASEDIR) clean
+	@cd tools && $(MAKE) BASEDIR=$(BASEDIR) clean
 	@for file in `$(FIND) interactive tests -name Makefile`; do \
 	  (cd `dirname $$file` && $(MAKE) BASEDIR=$(BASEDIR) clean); \
 	done
diff --git a/testsuite/lib/empty b/testsuite/lib/empty
deleted file mode 100644
index e69de29b..00000000
diff --git a/testsuite/makefiles/Makefile.common b/testsuite/makefiles/Makefile.common
index 8b3a075d..91ab0146 100644
--- a/testsuite/makefiles/Makefile.common
+++ b/testsuite/makefiles/Makefile.common
@@ -14,92 +14,7 @@
 #**************************************************************************
 
 TOPDIR=$(BASEDIR)/..
-WINTOPDIR=`cygpath -m "$(TOPDIR)"`
-
-# TOPDIR is the root directory of the OCaml sources, in Unix syntax.
-# WINTOPDIR is the same directory, in Windows syntax.
-
-OTOPDIR=$(TOPDIR)
-CTOPDIR=$(TOPDIR)
-CYGPATH=echo
-DIFF=diff -q
-SORT=sort
-SET_LD_PATH=CAML_LD_LIBRARY_PATH="$(LD_PATH)"
-
-# The variables above may be overridden by .../config/Makefile
-# OTOPDIR is either TOPDIR or WINTOPDIR, whichever is appropriate for
-#   arguments given to the OCaml compiler.
-# CTOPDIR is either TOPDIR or WINTOPDIR, whichever is appropriate for
-#   arguments given to the C and Fortran compilers.
-# 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.
-# 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
-#   (CAML_LD_LIBRARY_PATH for Unix, PATH for Windows) using the LD_PATH shell
-#   variable. Note that for Windows we add Unix-syntax directory names in
-#   PATH, and Cygwin will translate it to Windows syntax.
-
-include $(TOPDIR)/config/Makefile
-
-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=
-
-ifeq ($(SUPPORTS_SHARED_LIBRARIES),false)
-  CUSTOM = -custom
-else
-  CUSTOM =
-endif
-
-OCAML=$(OCAMLRUN) $(OTOPDIR)/ocaml $(OCFLAGS) \
-      -init $(OTOPDIR)/testsuite/lib/empty
-ifeq "$(FLEXLINK)" ""
-  FLEXLINK_PREFIX=
-else
-  ifeq "$(wildcard $(TOPDIR)/flexdll/Makefile)" ""
-    FLEXLINK_PREFIX=
-  else
-    EMPTY=
-    FLEXLINK_PREFIX=OCAML_FLEXLINK="$(WINTOPDIR)/boot/ocamlrun \
-	                            $(WINTOPDIR)/flexdll/flexlink.exe" $(EMPTY)
-  endif
-endif
-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=$(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)
-DUMPOBJ=$(OCAMLRUN) $(OTOPDIR)/tools/dumpobj
-OBJINFO=$(OCAMLRUN) $(OTOPDIR)/tools/objinfo
-BYTECODE_ONLY=[ "$(ARCH)" = "none" -o "$(ASM)" = "none" ]
-NATIVECODE_ONLY=false
-
-#FORTRAN_COMPILER=
-#FORTRAN_LIBRARY=
-
-UNIXLIBVAR=`case "$(OTHERLIBRARIES)" in *win32unix*) echo win32;; esac`
+include $(TOPDIR)/Makefile.tools
 
 defaultpromote:
 	@for file in *.reference; do \
@@ -108,6 +23,7 @@ defaultpromote:
 
 defaultclean:
 	@rm -f *.cmo *.cmi *.cmx *.cma *.cmxa *.cmxs *.$(O) *.$(SO) *.$(A) *.exe
+	@rm -f *.exe.manifest
 	@for dsym in *.dSYM; do \
 	  if [ -d $$dsym ]; then \
 	    rm -fr $$dsym; \
diff --git a/testsuite/makefiles/Makefile.expect b/testsuite/makefiles/Makefile.expect
new file mode 100644
index 00000000..0b219ee8
--- /dev/null
+++ b/testsuite/makefiles/Makefile.expect
@@ -0,0 +1,32 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                  Jeremie Dimino, Jane Street Europe                    *
+#*                                                                        *
+#*   Copyright 2016 Jane Street Group LLC                                 *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+default:
+	@for file in *.ml; do \
+	  printf " ... testing '$$file':"; \
+	  TERM=dumb $(EXPECT_TEST) -repo-root $(OTOPDIR) $$file && \
+	  TERM=dumb $(EXPECT_TEST) -repo-root $(OTOPDIR) -principal \
+	    $$file.corrected && \
+	  mv $$file.corrected.corrected $$file.corrected && \
+	  $(DIFF) $$file $$file.corrected && \
+	  echo " => passed" || echo " => failed"; \
+	done
+
+promote:
+	@for file in *.corrected; do \
+	  cp $$file `basename $$file .corrected`; \
+	done
+
+clean: defaultclean
+	@rm -f *.corrected
diff --git a/testsuite/makefiles/Makefile.okbad b/testsuite/makefiles/Makefile.okbad
index e3928dd9..d463181e 100644
--- a/testsuite/makefiles/Makefile.okbad
+++ b/testsuite/makefiles/Makefile.okbad
@@ -16,21 +16,30 @@
 .PHONY: default
 default: compile
 
+# See run-file in Makefile.several for the use of mktemp
 .PHONY: compile
 compile:
 	@for file in *.ml; do \
 	  printf " ... testing '$$file'"; \
+	  if [ `echo $$file | grep principal` ]; \
+	  then PRIN="-principal -w +18+19 -warn-error A"; \
+	  else PRIN=""; fi; \
 	  if [ `echo $$file | grep bad` ]; then \
-	    $(OCAMLC) -c -w a $$file 2>/dev/null \
+	    $(OCAMLC) -c -w a $$PRIN $$file 2>/dev/null \
             && echo " => failed" || echo " => passed"; \
 	  else \
 	    F="`basename $$file .ml`"; \
-	    test -f $$F.mli && $(OCAMLC) -c -w a $$F.mli; \
-	    $(OCAMLC) -c -w a $$file 2>/dev/null \
+	    test -f $$F.mli && $(OCAMLC) -c -w a $$PRIN $$F.mli; \
+	    $(OCAMLC) -c -w a $$PRIN $$file 2>/dev/null \
 	    && if [ -f $$F.reference ]; then \
-	         rm -f program.byte; \
-	         $(OCAMLC) $$F.cmo -o program.byte \
-	         && $(OCAMLRUN) program.byte >$$F.result \
+	         test -e program.byte.exe && { \
+	           T="`mktemp -p .`"; \
+	           mv -f program.byte.exe "$$T"; \
+	           rm -f "$$T"; \
+	         } ; \
+	         rm -f program.byte program.byte.exe; \
+	         $(OCAMLC) $$F.cmo -o program.byte$(EXE) \
+	         && $(OCAMLRUN) program.byte$(EXE) >$$F.result \
 	         && $(DIFF) $$F.reference $$F.result >/dev/null; \
 	       fi \
 	    && echo " => passed" || echo " => failed"; \
@@ -42,4 +51,4 @@ promote: defaultpromote
 
 .PHONY: clean
 clean: defaultclean
-	@rm -f program.byte *.cm* *.result
+	@rm -f program.byte program.byte.exe *.cm* *.result
diff --git a/testsuite/makefiles/Makefile.one b/testsuite/makefiles/Makefile.one
index 7488e3c3..c98fbb59 100644
--- a/testsuite/makefiles/Makefile.one
+++ b/testsuite/makefiles/Makefile.one
@@ -41,12 +41,19 @@ default:
 	 && echo " ... testing => skipped" \
 	 || $(SET_LD_PATH) $(MAKE) run
 
+# See run-file in Makefile.several for the use of mktemp (included for
+# completeness; should be unnecessary)
 .PHONY: compile
 compile: $(ML_FILES)
 	@for file in $(C_FILES); do \
 	  $(OCAMLC) -c $(C_INCLUDES) $$file.c; \
 	done
 	@if $(NATIVECODE_ONLY); then : ; else \
+	  test -e program.byte.exe && { \
+	    T="`mktemp -p .`"; \
+	    mv -f program.byte.exe "$$T"; \
+	    rm -f "$$T"; \
+	  } ; \
 	  rm -f program.byte program.byte.exe; \
 	  $(MAKE) $(CMO_FILES) $(MAIN_MODULE).cmo; \
 	  $(OCAMLC) $(ADD_COMPFLAGS) $(ADD_CFLAGS) -o program.byte$(EXE) \
@@ -54,6 +61,11 @@ compile: $(ML_FILES)
 	            $(MAIN_MODULE).cmo; \
 	fi
 	@if $(BYTECODE_ONLY); then : ; else \
+	  test -e program.native.exe && { \
+	    T="`mktemp -p .`"; \
+	    mv -f program.native.exe "$$T"; \
+	    rm -f "$$T"; \
+	  } ; \
 	  rm -f program.native program.native.exe; \
 	  $(MAKE) $(CMX_FILES) $(MAIN_MODULE).cmx; \
 	  $(OCAMLOPT) $(ADD_COMPFLAGS) $(ADD_OPTCOMPFLAGS) \
@@ -67,14 +79,15 @@ run:
 	@printf " ... testing with"
 	@if $(NATIVECODE_ONLY); then : ; else \
 	   printf " ocamlc"; \
-	   $(MYRUNTIME) ./program.byte$(EXE) $(EXEC_ARGS) \
+	   FLAMBDA=$(FLAMBDA) $(MYRUNTIME) ./program.byte$(EXE) $(EXEC_ARGS) \
 	                >$(MAIN_MODULE).result \
 	   && $(DIFF) $(MAIN_MODULE).reference $(MAIN_MODULE).result \
 	      >/dev/null; \
 	 fi \
 	&& if $(BYTECODE_ONLY); then : ; else \
 	     printf " ocamlopt"; \
-	     ./program.native$(EXE) $(EXEC_ARGS) > $(MAIN_MODULE).result \
+	     FLAMBDA=$(FLAMBDA) ./program.native$(EXE) $(EXEC_ARGS) \
+	                             > $(MAIN_MODULE).result \
 	     && $(DIFF) $(MAIN_MODULE).reference $(MAIN_MODULE).result \
 	                >/dev/null; \
 	   fi \
diff --git a/testsuite/makefiles/Makefile.several b/testsuite/makefiles/Makefile.several
index d5299d74..f24aff91 100644
--- a/testsuite/makefiles/Makefile.several
+++ b/testsuite/makefiles/Makefile.several
@@ -30,6 +30,8 @@ ADD_OPTFLAGS+=$(FORTRAN_LIB)
 
 C_INCLUDES+=-I $(CTOPDIR)/byterun -I$(CTOPDIR)/otherlibs/bigarray
 
+GENERATED_SOURCES=
+
 SKIP=false
 
 .PHONY: check
@@ -95,10 +97,23 @@ run-all:
 	  && echo " => passed" || echo " => failed"; \
 	done
 
+# On Windows, nefarious software (specifically Windows Defender) can prevent
+# executable files being deleted while it scans them. Unfortunately, it does
+# this by allowing the delete system call (either via rm -f or cmd /c del) to
+# complete with success but the file can linger for seconds or even minutes
+# until it suddenly disappears. During this time, the file cannot be overwritten
+# but it can be renamed, hence the odd use of mktemp. Some tests compiled with
+# flambda seem to be consistently "interesting" to Windows Defender. Note that
+# the interference doesn't appear to affect the execution of the tests.
 .PHONY: run-file
 run-file:
 	@printf " $(DESC)"
-	@rm -f program program.exe
+	@test -e program.exe && { \
+	  T="`mktemp -p .`"; \
+	  mv -f program.exe "$$T"; \
+	  rm -f "$$T"; \
+	} || true
+	@rm -f program program$(EXE)
 	@$(COMP) $(COMPFLAGS) $(FILE) -o program$(EXE)
 	@F="`basename $(FILE) .ml`"; \
 	if [ -f $$F.runner ]; then \
@@ -108,9 +123,15 @@ run-file:
 	fi \
 	&& \
 	if [ -f $$F.checker ]; then \
-	  DIFF="$(DIFF)" SORT="$(SORT)" sh $$F.checker; \
+	  DIFF="$(DIFF)" SORT="$(SORT)" sh $$F.checker || { \
+	    printf "  Error: output checker failed!\n"; \
+	    exit 1; \
+	  }; \
 	else \
-	  $(DIFF) $$F.reference $$F.result >/dev/null; \
+	  $(DIFF) $$F.reference $$F.result >/dev/null || { \
+	    printf "  Error: results don't match reference output!\n"; \
+	    exit 1; \
+	  }; \
 	fi
 
 .PHONY: promote
@@ -118,4 +139,4 @@ promote: defaultpromote
 
 .PHONY: clean
 clean: defaultclean
-	@rm -f *.result program program.exe
+	@rm -f *.result program program.exe $(GENERATED_SOURCES)
diff --git a/testsuite/tests/array-functions/test.ml b/testsuite/tests/array-functions/test.ml
index 5a6f810f..e325724c 100644
--- a/testsuite/tests/array-functions/test.ml
+++ b/testsuite/tests/array-functions/test.ml
@@ -26,7 +26,7 @@ let () =
   assert (not (Array.exists (fun a -> a mod 2 = 0)  [|1;3;5|]));
   assert (not (Array.exists (fun _ -> true) [||]));
   assert (Array.exists (fun a -> a.(9) = 1) (Array.make_matrix 10 10 1));
-  let f = Array.make_float 10 in
+  let f = Array.create_float 10 in
   Array.fill f 0 10 1.0;
   assert (Array.exists (fun a -> a = 1.0) f);
 ;;
@@ -99,7 +99,7 @@ let () =
   assert (not (Array.for_all (fun x -> x mod 2 = 0) [|2;3;6|]));
   assert (Array.for_all (fun _ -> false) [||]);
   assert (Array.for_all (fun a -> a.(9) = 1) (Array.make_matrix 10 10 1));
-  let f = Array.make_float 10 in
+  let f = Array.create_float 10 in
   Array.fill f 0 10 1.0;
   assert (Array.for_all (fun a -> a = 1.0) f);
 ;;
@@ -147,7 +147,7 @@ let () =
   assert (Array.mem [|1;2;3|] [|[|1;2;3|];[|2;3;4|];[|0|]|]);
   assert (Array.mem 1 (Array.make 100 1));
   assert (Array.mem (ref 1) (Array.make 100 (ref 1)));
-  let f = Array.make_float 10 in
+  let f = Array.create_float 10 in
   Array.fill f 0 10 1.0;
   assert (Array.mem 1.0 f);
 ;;
@@ -174,7 +174,7 @@ let () =
   assert (not (Array.memq [|1;2;3|] [|[|1;2;3|];[|2;3;4|];[|0|]|]));
   assert (Array.memq 1 (Array.make 100 1));
   assert (not (Array.memq (ref 1) (Array.make 100 (ref 1))));
-  let f = Array.make_float 10 in
+  let f = Array.create_float 10 in
   Array.fill f 0 10 1.0;
   assert (not (Array.memq 1.0 f));
 ;;
diff --git a/testsuite/tests/asmcomp/Makefile b/testsuite/tests/asmcomp/Makefile
index 212f4112..abcb8729 100644
--- a/testsuite/tests/asmcomp/Makefile
+++ b/testsuite/tests/asmcomp/Makefile
@@ -18,6 +18,7 @@ BASEDIR=../..
 INCLUDES=\
   -I $(OTOPDIR)/utils \
   -I $(OTOPDIR)/typing \
+  -I $(OTOPDIR)/middle_end \
   -I $(OTOPDIR)/bytecomp \
   -I $(OTOPDIR)/asmcomp
 
@@ -47,10 +48,17 @@ parsecmm.mli parsecmm.ml: parsecmm.mly
 lexcmm.ml: lexcmm.mll
 	@$(OCAMLLEX) -q lexcmm.mll
 
-MLCASES=optargs staticalloc bind_tuples is_static register_typing
+MLCASES=optargs staticalloc bind_tuples is_static register_typing \
+  register_typing_switch
 ARGS_is_static=-I $(OTOPDIR)/byterun is_in_static_data.c
-MLCASES_FLAMBDA=is_static_flambda unrolling_flambda
-ARGS_is_static_flambda=-I $(OTOPDIR)/byterun is_in_static_data.c
+MLCASES_FLAMBDA=is_static_flambda unrolling_flambda unrolling_flambda2 \
+  static_float_array_flambda static_float_array_flambda_opaque
+ARGS_is_static_flambda=\
+  -I $(OTOPDIR)/byterun is_in_static_data.c is_static_flambda_dep.ml
+ARGS_static_float_array_flambda=\
+  -I $(OTOPDIR)/byterun is_in_static_data.c simple_float_const.ml
+ARGS_static_float_array_flambda_opaque=\
+  -I $(OTOPDIR)/byterun is_in_static_data.c -opaque simple_float_const_opaque.ml
 
 CASES=fib tak quicksort quicksort2 soli \
       arith checkbound tagged-fib tagged-integr tagged-quicksort tagged-tak
@@ -66,9 +74,10 @@ ARGS_tagged-fib=-DINT_INT -DFUN=fib main.c
 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
+ARGS_staticalloc=-I $(OTOPDIR)/utils config.cmx
 
 skips:
-	@for c in $(CASES) $(MLCASES); do \
+	@for c in $(CASES) $(MLCASES) $(MLCASES_FLAMBDA); do \
 	  echo " ... testing '$$c': => skipped"; \
 	done
 
@@ -81,7 +90,7 @@ one_ml_flambda:
 	   $(OCAMLOPT) $(ARGS_$(NAME)) -o $(NAME).exe $(NAME).ml && \
 	   ./$(NAME).exe && echo " => passed" || echo " => failed"; \
 	 else \
-	   echo "=> skipped"; \
+	   echo " => skipped"; \
 	 fi
 
 one:
@@ -102,6 +111,11 @@ else
 SKIP=false
 endif
 
+ifeq "$(WITH_SPACETIME)" "true"
+# These tests have not been ported for Spacetime
+SKIP=true
+endif
+
 ifeq ($(CCOMPTYPE),msvc)
 CC=set -o pipefail ; $(NATIVECC) $(CFLAGS) /Fe$(1) | tail -n +2
 CFLAGS=$(NATIVECCCOMPOPTS)
diff --git a/testsuite/tests/asmcomp/bind_tuples.ml b/testsuite/tests/asmcomp/bind_tuples.ml
index 503b3a34..a6dd2947 100755
--- a/testsuite/tests/asmcomp/bind_tuples.ml
+++ b/testsuite/tests/asmcomp/bind_tuples.ml
@@ -1,24 +1,9 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed 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 the effectiveness of optimized compilation of tuple binding
 
    Ref: http://caml.inria.fr/mantis/view.php?id=4800
 *)
 
-let () =
+let f () =
   let x0 = Gc.allocated_bytes () in
   let x1 = Gc.allocated_bytes () in
 
@@ -38,3 +23,6 @@ let () =
   print_int !r;
   assert (!r = 82);
   assert(x1 -. x0 = x2 -. x1) (* check no allocation between x1 and x2 *)
+  [@@inline never]
+
+let () = f ()
diff --git a/testsuite/tests/asmcomp/is_static_flambda.ml b/testsuite/tests/asmcomp/is_static_flambda.ml
index 6766fb8d..d4cf2756 100644
--- a/testsuite/tests/asmcomp/is_static_flambda.ml
+++ b/testsuite/tests/asmcomp/is_static_flambda.ml
@@ -91,3 +91,25 @@ let () =
     try (failwith [@inlined always]) "some other string" with exn -> exn
   in
   assert(is_in_static_data exn)
+
+(* Verify that approximation intersection correctly loads exported
+   approximations.
+
+   Is_static_flambda_dep.pair is a pair with 1 as first element. The
+   intersection of approximations should return a block with
+   approximation: [tag 0: [tag 0: Int 1, Unknown], Unknown] *)
+let f x =
+  let pair =
+    if Sys.opaque_identity x then
+      (1, 2), 3
+    else
+      Is_static_flambda_dep.pair, 4
+  in
+  let n = fst (fst pair) in
+  let res = n, n in
+  assert(is_in_static_data res)
+  [@@inline never]
+
+let () =
+  f true;
+  f false
diff --git a/testsuite/tests/asmcomp/is_static_flambda_dep.ml b/testsuite/tests/asmcomp/is_static_flambda_dep.ml
new file mode 100644
index 00000000..3a50f7ca
--- /dev/null
+++ b/testsuite/tests/asmcomp/is_static_flambda_dep.ml
@@ -0,0 +1 @@
+let pair = 1, 12
diff --git a/testsuite/tests/asmcomp/lexcmm.mli b/testsuite/tests/asmcomp/lexcmm.mli
index 18fdf7c0..f9fe6afa 100644
--- a/testsuite/tests/asmcomp/lexcmm.mli
+++ b/testsuite/tests/asmcomp/lexcmm.mli
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 val token: Lexing.lexbuf -> Parsecmm.token
 
 type error =
diff --git a/testsuite/tests/asmcomp/lexcmm.mll b/testsuite/tests/asmcomp/lexcmm.mll
index 6b985eb8..d3c0d394 100644
--- a/testsuite/tests/asmcomp/lexcmm.mll
+++ b/testsuite/tests/asmcomp/lexcmm.mll
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 {
 open Parsecmm
 
@@ -61,9 +46,8 @@ let keyword_table =
     "mulh", MULH;
     "or", OR;
     "proj", PROJ;
-    "raise", RAISE Lambda.Raise_regular;
-    "reraise", RAISE Lambda.Raise_reraise;
-    "raise_notrace", RAISE Lambda.Raise_notrace;
+    "raise_withtrace", RAISE Cmm.Raise_withtrace;
+    "raise_notrace", RAISE Cmm.Raise_notrace;
     "seq", SEQ;
     "signed", SIGNED;
     "skip", SKIP;
diff --git a/testsuite/tests/asmcomp/main.ml b/testsuite/tests/asmcomp/main.ml
index 48ff1f77..c094bd09 100644
--- a/testsuite/tests/asmcomp/main.ml
+++ b/testsuite/tests/asmcomp/main.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Clflags
 
 let compile_file filename =
diff --git a/testsuite/tests/asmcomp/mainarith.c b/testsuite/tests/asmcomp/mainarith.c
index 492951b2..de876bfe 100644
--- a/testsuite/tests/asmcomp/mainarith.c
+++ b/testsuite/tests/asmcomp/mainarith.c
@@ -91,7 +91,7 @@ void do_test(void)
       INTTEST(R[15], (X - 1));
       INTTEST(R[16], (X - -1));
 
-      INTTEST(R[17], ((intnat) ((char *)R - 8)));
+      INTTEST(R[17], ((intnat) ((uintnat)R - 8)));
       INTTEST(R[18], ((intnat) ((char *)R - Y)));
 
       INTTEST(R[19], (X * 2));
diff --git a/testsuite/tests/asmcomp/optargs.ml b/testsuite/tests/asmcomp/optargs.ml
index 43982faf..a4f40407 100644
--- a/testsuite/tests/asmcomp/optargs.ml
+++ b/testsuite/tests/asmcomp/optargs.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed 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 the effectiveness of inlining the wrapper which fills in
    default values for optional arguments.
 
diff --git a/testsuite/tests/asmcomp/parsecmm.mly b/testsuite/tests/asmcomp/parsecmm.mly
index c372abf4..a1eea39f 100644
--- a/testsuite/tests/asmcomp/parsecmm.mly
+++ b/testsuite/tests/asmcomp/parsecmm.mly
@@ -1,18 +1,3 @@
-/**************************************************************************/
-/*                                                                        */
-/*                                OCaml                                   */
-/*                                                                        */
-/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
-/*                                                                        */
-/*   Copyright 1996 Institut National de Recherche en Informatique et     */
-/*     en Automatique.                                                    */
-/*                                                                        */
-/*   All rights reserved.  This file is distributed under the terms of    */
-/*   the GNU Lesser General Public License version 2.1, with the          */
-/*   special exception on linking described in the file LICENSE.          */
-/*                                                                        */
-/**************************************************************************/
-
 /* A simple parser for C-- */
 
 %{
@@ -113,7 +98,7 @@ let access_array base numelt size =
 %token OR
 %token  POINTER
 %token PROJ
-%token  RAISE
+%token  RAISE
 %token RBRACKET
 %token RPAREN
 %token SEQ
@@ -188,7 +173,7 @@ expr:
   | LPAREN APPLY expr exprlist machtype RPAREN
                 { Cop(Capply($5, Debuginfo.none), $3 :: List.rev $4) }
   | LPAREN EXTCALL STRING exprlist machtype RPAREN
-                { Cop(Cextcall($3, $5, false, Debuginfo.none), List.rev $4) }
+               {Cop(Cextcall($3, $5, false, Debuginfo.none, None), List.rev $4)}
   | LPAREN SUBF expr RPAREN { Cop(Cnegf, [$3]) }
   | LPAREN SUBF expr expr RPAREN { Cop(Csubf, [$3; $4]) }
   | LPAREN unaryop expr RPAREN { Cop($2, [$3]) }
@@ -253,7 +238,7 @@ chunk:
 ;
 unaryop:
     LOAD chunk                  { Cload $2 }
-  | ALLOC                       { Calloc }
+  | ALLOC                       { Calloc Debuginfo.none }
   | FLOATOFINT                  { Cfloatofint }
   | INTOFFLOAT                  { Cintoffloat }
   | RAISE                       { Craise ($1, Debuginfo.none) }
@@ -322,15 +307,12 @@ datalist:
 ;
 dataitem:
     STRING COLON                { Cdefine_symbol $1 }
-  | INTCONST COLON              { Cdefine_label $1 }
   | BYTE INTCONST               { Cint8 $2 }
   | HALF INTCONST               { Cint16 $2 }
   | INT INTCONST                { Cint(Nativeint.of_int $2) }
   | FLOAT FLOATCONST            { Cdouble (float_of_string $2) }
   | ADDR STRING                 { Csymbol_address $2 }
-  | ADDR INTCONST               { Clabel_address $2 }
   | VAL STRING                 { Csymbol_address $2 }
-  | VAL INTCONST               { Clabel_address $2 }
   | KSTRING STRING              { Cstring $2 }
   | SKIP INTCONST               { Cskip $2 }
   | ALIGN INTCONST              { Calign $2 }
diff --git a/testsuite/tests/asmcomp/parsecmmaux.ml b/testsuite/tests/asmcomp/parsecmmaux.ml
index b4671dfa..d2199cbe 100644
--- a/testsuite/tests/asmcomp/parsecmmaux.ml
+++ b/testsuite/tests/asmcomp/parsecmmaux.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Auxiliary functions for parsing *)
 
 type error =
diff --git a/testsuite/tests/asmcomp/parsecmmaux.mli b/testsuite/tests/asmcomp/parsecmmaux.mli
index b219b963..c7920803 100644
--- a/testsuite/tests/asmcomp/parsecmmaux.mli
+++ b/testsuite/tests/asmcomp/parsecmmaux.mli
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Auxiliary functions for parsing *)
 
 val bind_ident: string -> Ident.t
diff --git a/testsuite/tests/asmcomp/register_typing_switch.ml b/testsuite/tests/asmcomp/register_typing_switch.ml
new file mode 100644
index 00000000..18c4416d
--- /dev/null
+++ b/testsuite/tests/asmcomp/register_typing_switch.ml
@@ -0,0 +1,21 @@
+type 'a typ = Int : int typ | Ptr : int list typ | Int2 : int typ
+
+let f (type a) (t : a typ) (p : int list) : a =
+  match t with
+  | Int -> 100
+  | Ptr -> p
+  | Int2 -> 200
+
+let allocate_garbage () =
+  for i = 0 to 100 do
+    ignore (Array.make 200 0.0)
+  done
+
+let g (t : int list typ) x =
+  Gc.minor ();
+  let x = f t ([x; x; x; x; x]) in
+  Gc.minor ();
+  allocate_garbage ();
+  ignore (String.length (String.concat " " (List.map string_of_int x)))
+
+let () = g Ptr 5
diff --git a/testsuite/tests/asmcomp/simple_float_const.ml b/testsuite/tests/asmcomp/simple_float_const.ml
new file mode 100644
index 00000000..1aca414f
--- /dev/null
+++ b/testsuite/tests/asmcomp/simple_float_const.ml
@@ -0,0 +1 @@
+let f = 3.14
diff --git a/testsuite/tests/asmcomp/simple_float_const_opaque.ml b/testsuite/tests/asmcomp/simple_float_const_opaque.ml
new file mode 100644
index 00000000..1aca414f
--- /dev/null
+++ b/testsuite/tests/asmcomp/simple_float_const_opaque.ml
@@ -0,0 +1 @@
+let f = 3.14
diff --git a/testsuite/tests/asmcomp/soli.cmm b/testsuite/tests/asmcomp/soli.cmm
index a30da9a2..c8ffc5d6 100644
--- a/testsuite/tests/asmcomp/soli.cmm
+++ b/testsuite/tests/asmcomp/soli.cmm
@@ -66,7 +66,7 @@
                                  (intaset (addraref "board" i1) j1 1)
                                  (intaset (addraref "board" i2) j2 2)
                                  (if (app "solve" (+ m 1) int)
-                                     (raise 0a)
+                                     (raise_notrace 0a)
                                    [])
                                  (intaset (addraref "board" i) j 2)
                                  (intaset (addraref "board" i1) j1 2)
diff --git a/testsuite/tests/asmcomp/static_float_array_flambda.ml b/testsuite/tests/asmcomp/static_float_array_flambda.ml
new file mode 100644
index 00000000..f60e530a
--- /dev/null
+++ b/testsuite/tests/asmcomp/static_float_array_flambda.ml
@@ -0,0 +1,18 @@
+external is_in_static_data : 'a -> bool = "caml_is_in_static_data"
+
+let a = [|0.; 1.|]
+let f = 1.23
+let b = [|0.; f; f|]
+let g = Sys.opaque_identity 1.23
+let c = [|0.; g|]
+let d = [|0.; Simple_float_const.f|]
+
+let () = assert(is_in_static_data a)
+let () = assert(is_in_static_data f)
+let () = assert(is_in_static_data b)
+
+let () = assert(not (is_in_static_data c))
+(* In fact this one could be static by preallocating the array then
+   patching it when g is available *)
+
+let () = assert(is_in_static_data d)
diff --git a/testsuite/tests/asmcomp/static_float_array_flambda_opaque.ml b/testsuite/tests/asmcomp/static_float_array_flambda_opaque.ml
new file mode 100644
index 00000000..518f48bc
--- /dev/null
+++ b/testsuite/tests/asmcomp/static_float_array_flambda_opaque.ml
@@ -0,0 +1,21 @@
+external is_in_static_data : 'a -> bool = "caml_is_in_static_data"
+
+let a = [|0.; 1.|]
+let f = 1.23
+let b = [|0.; f; f|]
+let g = Sys.opaque_identity 1.23
+let c = [|0.; g|]
+let d = [|0.; Simple_float_const_opaque.f|]
+
+let () = assert(is_in_static_data a)
+let () = assert(is_in_static_data f)
+let () = assert(is_in_static_data b)
+
+let () = assert(not (is_in_static_data c))
+(* In fact this one could be static by preallocating the array then
+   patching it when g is available *)
+
+let () = assert(not (is_in_static_data d))
+(* The dependency Simple_float_const_opaque is built with opaque,
+   hence the value of Simple_float_const_opaque.f cannot be known
+   preventing the static allocation of d *)
diff --git a/testsuite/tests/asmcomp/staticalloc.ml b/testsuite/tests/asmcomp/staticalloc.ml
index de850797..2e7c9a16 100644
--- a/testsuite/tests/asmcomp/staticalloc.ml
+++ b/testsuite/tests/asmcomp/staticalloc.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed 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 the effectiveness of structured constant propagation and
    static allocation.
 
@@ -28,7 +13,7 @@ let () =
   let g () = (a, fst b) in
   assert (g () == ((1,2), (1,2)));
   assert (fst (pair a a) == (1, 2));
-  assert (snd b != ["x"; "y"]);  (* mutable "constant", cannot be shared *)
+  assert (snd b != ["x"; "y"] || Config.safe_string);  (* mutable "constant", cannot be shared *)
   let x2 = Gc.allocated_bytes () in
   assert(x1 -. x0 = x2 -. x1)
      (* check that we did not allocated anything between x1 and x2 *)
diff --git a/testsuite/tests/asmcomp/unrolling_flambda2.ml b/testsuite/tests/asmcomp/unrolling_flambda2.ml
new file mode 100644
index 00000000..cccda47d
--- /dev/null
+++ b/testsuite/tests/asmcomp/unrolling_flambda2.ml
@@ -0,0 +1,20 @@
+
+type t = { fn : t -> t -> int -> unit -> unit }
+
+let rec foo f b n x =
+  if n < 0 then ()
+  else begin
+    foo f b (n - 1) x;
+    b.fn f b (n - 1) x
+  end
+[@@specialise always]
+
+let rec bar f b n x =
+  if n < 0 then ()
+  else begin
+    bar f b (n - 1) x;
+    f.fn f b (n - 1) x
+  end
+[@@specialise always]
+
+let () = foo {fn = foo} {fn = bar} 10 ()
diff --git a/testsuite/tests/ast-invariants/test.ml b/testsuite/tests/ast-invariants/test.ml
index b5c4ea21..21e5e8c4 100644
--- a/testsuite/tests/ast-invariants/test.ml
+++ b/testsuite/tests/ast-invariants/test.ml
@@ -1,22 +1,8 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                                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].
+   is to ensure that the parser doesn't accept more than [Ast_invariants].
 *)
 
 let root = "../../.."
diff --git a/testsuite/tests/backtrace/Makefile b/testsuite/tests/backtrace/Makefile
index 7566c193..5df19fc6 100644
--- a/testsuite/tests/backtrace/Makefile
+++ b/testsuite/tests/backtrace/Makefile
@@ -19,9 +19,14 @@ EXECNAME=program$(EXE)
 ABCDFILES=backtrace.ml
 OTHERFILES=backtrace2.ml backtrace3.ml raw_backtrace.ml \
            backtrace_deprecated.ml backtrace_slots.ml
+INLININGFILES=inline_test.ml inline_traversal_test.ml
 OTHERFILESNOINLINING=pr6920_why_at.ml pr6920_why_swallow.ml
 OTHERFILESNOINLINING_NATIVE=backtraces_and_finalizers.ml
 
+# Keep only filenames, lines and character ranges
+LOCATIONFILTER=grep -oE \
+               '[a-zA-Z_]+\.ml(:[0-9]+)?|(line|characters) [0-9-]+'
+
 default:
 	@$(MAKE) byte
 	@if $(BYTECODE_ONLY); then $(MAKE) skip ; else $(MAKE) native; fi
@@ -37,7 +42,7 @@ byte:
 	    (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
               $(OCAMLRUN) $(EXECNAME) $$arg || true) \
 	         >$$F.$$arg.byte.result 2>&1; \
-	    $(DIFF) $$F.$$arg.reference $$F.$$arg.byte.result >/dev/null \
+	    $(DIFF) $$F.$$arg.byte.reference $$F.$$arg.byte.result >/dev/null \
 	    && echo " => passed" || echo " => failed"; \
 	  done; \
 	done
@@ -49,7 +54,19 @@ byte:
 	  (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
             $(OCAMLRUN) $(EXECNAME) $$arg || true) \
 	       >$$F.byte.result 2>&1; \
-	  $(DIFF) $$F.reference $$F.byte.result >/dev/null \
+	  $(DIFF) $$F.byte.reference $$F.byte.result >/dev/null \
+	  && echo " => passed" || echo " => failed"; \
+	done;
+	@for file in $(INLININGFILES); \
+	do \
+	  rm -f program program.exe; \
+	  $(OCAMLC) -g -o $(EXECNAME) $$file; \
+	  printf " ... testing '$$file' with ocamlc:"; \
+	  F="`basename $$file .ml`"; \
+	  (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
+	  $(OCAMLRUN) $(EXECNAME) $$arg 2>&1 || true) \
+			| $(LOCATIONFILTER) >$$F.byte.result 2>&1; \
+	  $(DIFF) $$F.byte.reference $$F.byte.result >/dev/null \
 	  && echo " => passed" || echo " => failed"; \
 	done
 
@@ -62,7 +79,7 @@ skip:
 	  done; \
 	done
 	@for file in $(OTHERFILES) $(OTHERFILESNOINLINING) \
-	             $(OTHERFILESNOINLINING_NATIVE); do \
+	             $(OTHERFILESNOINLINING_NATIVE) $(INLININGFILES); do \
 	  echo " ... testing '$$file' with ocamlopt: => skipped"; \
 	done
 
@@ -77,7 +94,8 @@ native:
 	    (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
               ./$(EXECNAME) $$arg || true) \
 	         >$$F.$$arg.native.result 2>&1; \
-	    $(DIFF) $$F.$$arg.reference $$F.$$arg.native.result >/dev/null \
+	    $(DIFF) $$F.$$arg.native.reference $$F.$$arg.native.result \
+	            >/dev/null \
 	    && echo " => passed" || echo " => failed"; \
 	  done; \
 	done
@@ -89,7 +107,7 @@ native:
 	  (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
             ./$(EXECNAME) $$arg || true) \
 	       >$$F.native.result 2>&1; \
-	  $(DIFF) $$F.reference $$F.native.result >/dev/null \
+	  $(DIFF) $$F.native.reference $$F.native.result >/dev/null \
 	  && echo " => passed" || echo " => failed"; \
 	done;
 	@for file in $(OTHERFILESNOINLINING) $(OTHERFILESNOINLINING_NATIVE); \
@@ -101,10 +119,32 @@ native:
 	  (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
             ./$(EXECNAME) $$arg || true) \
 	       >$$F.native.result 2>&1; \
-	  $(DIFF) $$F.reference $$F.native.result >/dev/null \
+	  $(DIFF) $$F.native.reference $$F.native.result >/dev/null \
+	  && echo " => passed" || echo " => failed"; \
+	done;
+	@for file in $(INLININGFILES); \
+	do \
+	  rm -f program program.exe; \
+	  $(OCAMLOPT) -g -o $(EXECNAME) $$file; \
+	  printf " ... testing '$$file' with ocamlopt:"; \
+	  F="`basename $$file .ml`"; \
+	  (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
+	  ./$(EXECNAME) $$arg 2>&1 || true) \
+		 	| $(LOCATIONFILTER) >$$F.native.result; \
+	  $(DIFF) $$F.native.reference $$F.native.result >/dev/null \
+	  && echo " => passed" || echo " => failed"; \
+	  rm -f program program.exe; \
+	  $(OCAMLOPT) -g -o $(EXECNAME) -O3 $$file; \
+	  printf " ... testing '$$file' with ocamlopt -O3:"; \
+	  F="`basename $$file .ml`"; \
+	  (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
+	  ./$(EXECNAME) $$arg 2>&1 || true) \
+		 	| $(LOCATIONFILTER) >$$F.O3.result; \
+	  $(DIFF) $$F.native.reference $$F.O3.result >/dev/null \
 	  && echo " => passed" || echo " => failed"; \
 	done
 
+
 .PHONY: promote
 promote: defaultpromote
 
diff --git a/testsuite/tests/backtrace/backtrace..byte.reference b/testsuite/tests/backtrace/backtrace..byte.reference
new file mode 100644
index 00000000..d2d69337
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace..byte.reference
@@ -0,0 +1,2 @@
+Fatal error: exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace.ml", line 18, characters 12-24
diff --git a/testsuite/tests/backtrace/backtrace..native.reference b/testsuite/tests/backtrace/backtrace..native.reference
new file mode 100644
index 00000000..d2d69337
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace..native.reference
@@ -0,0 +1,2 @@
+Fatal error: exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace.ml", line 18, characters 12-24
diff --git a/testsuite/tests/backtrace/backtrace..reference b/testsuite/tests/backtrace/backtrace..reference
deleted file mode 100644
index d2d69337..00000000
--- a/testsuite/tests/backtrace/backtrace..reference
+++ /dev/null
@@ -1,2 +0,0 @@
-Fatal error: exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace.ml", line 18, characters 12-24
diff --git a/testsuite/tests/backtrace/backtrace.a.byte.reference b/testsuite/tests/backtrace/backtrace.a.byte.reference
new file mode 100644
index 00000000..78981922
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace.a.byte.reference
@@ -0,0 +1 @@
+a
diff --git a/testsuite/tests/backtrace/backtrace.a.native.reference b/testsuite/tests/backtrace/backtrace.a.native.reference
new file mode 100644
index 00000000..78981922
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace.a.native.reference
@@ -0,0 +1 @@
+a
diff --git a/testsuite/tests/backtrace/backtrace.a.reference b/testsuite/tests/backtrace/backtrace.a.reference
deleted file mode 100644
index 78981922..00000000
--- a/testsuite/tests/backtrace/backtrace.a.reference
+++ /dev/null
@@ -1 +0,0 @@
-a
diff --git a/testsuite/tests/backtrace/backtrace.b.byte.reference b/testsuite/tests/backtrace/backtrace.b.byte.reference
new file mode 100644
index 00000000..47375896
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace.b.byte.reference
@@ -0,0 +1,11 @@
+b
+Fatal error: exception Backtrace.Error("b")
+Raised at file "backtrace.ml", line 7, characters 21-32
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 11, characters 4-11
+Re-raised at file "backtrace.ml", line 13, characters 68-71
+Called from file "backtrace.ml", line 18, characters 9-25
diff --git a/testsuite/tests/backtrace/backtrace.b.native.reference b/testsuite/tests/backtrace/backtrace.b.native.reference
new file mode 100644
index 00000000..f1e8da87
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace.b.native.reference
@@ -0,0 +1,11 @@
+b
+Fatal error: exception Backtrace.Error("b")
+Raised at file "backtrace.ml", line 7, characters 16-32
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 11, characters 4-11
+Re-raised at file "backtrace.ml", line 13, characters 62-71
+Called from file "backtrace.ml", line 18, characters 9-25
diff --git a/testsuite/tests/backtrace/backtrace.b.reference b/testsuite/tests/backtrace/backtrace.b.reference
deleted file mode 100644
index 47375896..00000000
--- a/testsuite/tests/backtrace/backtrace.b.reference
+++ /dev/null
@@ -1,11 +0,0 @@
-b
-Fatal error: exception Backtrace.Error("b")
-Raised at file "backtrace.ml", line 7, characters 21-32
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 11, characters 4-11
-Re-raised at file "backtrace.ml", line 13, characters 68-71
-Called from file "backtrace.ml", line 18, characters 9-25
diff --git a/testsuite/tests/backtrace/backtrace.c.byte.reference b/testsuite/tests/backtrace/backtrace.c.byte.reference
new file mode 100644
index 00000000..33cac474
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace.c.byte.reference
@@ -0,0 +1,3 @@
+Fatal error: exception Backtrace.Error("c")
+Raised at file "backtrace.ml", line 14, characters 26-37
+Called from file "backtrace.ml", line 18, characters 9-25
diff --git a/testsuite/tests/backtrace/backtrace.c.native.reference b/testsuite/tests/backtrace/backtrace.c.native.reference
new file mode 100644
index 00000000..431cd546
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace.c.native.reference
@@ -0,0 +1,3 @@
+Fatal error: exception Backtrace.Error("c")
+Raised at file "backtrace.ml", line 14, characters 20-37
+Called from file "backtrace.ml", line 18, characters 9-25
diff --git a/testsuite/tests/backtrace/backtrace.c.reference b/testsuite/tests/backtrace/backtrace.c.reference
deleted file mode 100644
index 33cac474..00000000
--- a/testsuite/tests/backtrace/backtrace.c.reference
+++ /dev/null
@@ -1,3 +0,0 @@
-Fatal error: exception Backtrace.Error("c")
-Raised at file "backtrace.ml", line 14, characters 26-37
-Called from file "backtrace.ml", line 18, characters 9-25
diff --git a/testsuite/tests/backtrace/backtrace.d.byte.reference b/testsuite/tests/backtrace/backtrace.d.byte.reference
new file mode 100644
index 00000000..9ba46824
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace.d.byte.reference
@@ -0,0 +1,9 @@
+Fatal error: exception Backtrace.Error("d")
+Raised at file "backtrace.ml", line 7, characters 21-32
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 11, characters 4-11
+Called from file "backtrace.ml", line 18, characters 9-25
diff --git a/testsuite/tests/backtrace/backtrace.d.native.reference b/testsuite/tests/backtrace/backtrace.d.native.reference
new file mode 100644
index 00000000..d074040c
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace.d.native.reference
@@ -0,0 +1,9 @@
+Fatal error: exception Backtrace.Error("d")
+Raised at file "backtrace.ml", line 7, characters 16-32
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 11, characters 4-11
+Called from file "backtrace.ml", line 18, characters 9-25
diff --git a/testsuite/tests/backtrace/backtrace.d.reference b/testsuite/tests/backtrace/backtrace.d.reference
deleted file mode 100644
index 9ba46824..00000000
--- a/testsuite/tests/backtrace/backtrace.d.reference
+++ /dev/null
@@ -1,9 +0,0 @@
-Fatal error: exception Backtrace.Error("d")
-Raised at file "backtrace.ml", line 7, characters 21-32
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 11, characters 4-11
-Called from file "backtrace.ml", line 18, characters 9-25
diff --git a/testsuite/tests/backtrace/backtrace2.byte.reference b/testsuite/tests/backtrace/backtrace2.byte.reference
new file mode 100644
index 00000000..82833fd9
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace2.byte.reference
@@ -0,0 +1,27 @@
+a
+No exception
+b
+Uncaught exception Backtrace2.Error("b")
+Raised at file "backtrace2.ml", line 7, characters 21-32
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 11, characters 4-11
+Re-raised at file "backtrace2.ml", line 13, characters 68-71
+Called from file "backtrace2.ml", line 18, characters 11-23
+Uncaught exception Backtrace2.Error("c")
+Raised at file "backtrace2.ml", line 14, characters 26-37
+Called from file "backtrace2.ml", line 18, characters 11-23
+Uncaught exception Backtrace2.Error("d")
+Raised at file "backtrace2.ml", line 7, characters 21-32
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 11, characters 4-11
+Called from file "backtrace2.ml", line 18, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace2.ml", line 18, characters 14-22
diff --git a/testsuite/tests/backtrace/backtrace2.native.reference b/testsuite/tests/backtrace/backtrace2.native.reference
new file mode 100644
index 00000000..5c75a66b
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace2.native.reference
@@ -0,0 +1,27 @@
+a
+No exception
+b
+Uncaught exception Backtrace2.Error("b")
+Raised at file "backtrace2.ml", line 7, characters 16-32
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 11, characters 4-11
+Re-raised at file "backtrace2.ml", line 13, characters 62-71
+Called from file "backtrace2.ml", line 18, characters 11-23
+Uncaught exception Backtrace2.Error("c")
+Raised at file "backtrace2.ml", line 14, characters 20-37
+Called from file "backtrace2.ml", line 18, characters 11-23
+Uncaught exception Backtrace2.Error("d")
+Raised at file "backtrace2.ml", line 7, characters 16-32
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 11, characters 4-11
+Called from file "backtrace2.ml", line 18, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace2.ml", line 18, characters 14-22
diff --git a/testsuite/tests/backtrace/backtrace2.reference b/testsuite/tests/backtrace/backtrace2.reference
deleted file mode 100644
index 82833fd9..00000000
--- a/testsuite/tests/backtrace/backtrace2.reference
+++ /dev/null
@@ -1,27 +0,0 @@
-a
-No exception
-b
-Uncaught exception Backtrace2.Error("b")
-Raised at file "backtrace2.ml", line 7, characters 21-32
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 11, characters 4-11
-Re-raised at file "backtrace2.ml", line 13, characters 68-71
-Called from file "backtrace2.ml", line 18, characters 11-23
-Uncaught exception Backtrace2.Error("c")
-Raised at file "backtrace2.ml", line 14, characters 26-37
-Called from file "backtrace2.ml", line 18, characters 11-23
-Uncaught exception Backtrace2.Error("d")
-Raised at file "backtrace2.ml", line 7, characters 21-32
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 11, characters 4-11
-Called from file "backtrace2.ml", line 18, characters 11-23
-Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace2.ml", line 18, characters 14-22
diff --git a/testsuite/tests/backtrace/backtrace3.byte.reference b/testsuite/tests/backtrace/backtrace3.byte.reference
new file mode 100644
index 00000000..5081640a
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace3.byte.reference
@@ -0,0 +1,27 @@
+a
+No exception
+b
+Uncaught exception Backtrace3.Error("b")
+Raised at file "backtrace3.ml", line 7, characters 21-32
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 11, characters 4-11
+Re-raised at file "backtrace3.ml", line 20, characters 47-50
+Called from file "backtrace3.ml", line 28, characters 11-23
+Uncaught exception Backtrace3.Error("c")
+Raised at file "backtrace3.ml", line 24, characters 12-23
+Called from file "backtrace3.ml", line 28, characters 11-23
+Uncaught exception Backtrace3.Error("d")
+Raised at file "backtrace3.ml", line 7, characters 21-32
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 11, characters 4-11
+Called from file "backtrace3.ml", line 28, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace3.ml", line 28, characters 14-22
diff --git a/testsuite/tests/backtrace/backtrace3.native.reference b/testsuite/tests/backtrace/backtrace3.native.reference
new file mode 100644
index 00000000..c38a51e7
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace3.native.reference
@@ -0,0 +1,27 @@
+a
+No exception
+b
+Uncaught exception Backtrace3.Error("b")
+Raised at file "backtrace3.ml", line 7, characters 16-32
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 11, characters 4-11
+Re-raised at file "backtrace3.ml", line 20, characters 41-50
+Called from file "backtrace3.ml", line 28, characters 11-23
+Uncaught exception Backtrace3.Error("c")
+Raised at file "backtrace3.ml", line 24, characters 6-23
+Called from file "backtrace3.ml", line 28, characters 11-23
+Uncaught exception Backtrace3.Error("d")
+Raised at file "backtrace3.ml", line 7, characters 16-32
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 11, characters 4-11
+Called from file "backtrace3.ml", line 28, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace3.ml", line 28, characters 14-22
diff --git a/testsuite/tests/backtrace/backtrace3.reference b/testsuite/tests/backtrace/backtrace3.reference
deleted file mode 100644
index 5081640a..00000000
--- a/testsuite/tests/backtrace/backtrace3.reference
+++ /dev/null
@@ -1,27 +0,0 @@
-a
-No exception
-b
-Uncaught exception Backtrace3.Error("b")
-Raised at file "backtrace3.ml", line 7, characters 21-32
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 11, characters 4-11
-Re-raised at file "backtrace3.ml", line 20, characters 47-50
-Called from file "backtrace3.ml", line 28, characters 11-23
-Uncaught exception Backtrace3.Error("c")
-Raised at file "backtrace3.ml", line 24, characters 12-23
-Called from file "backtrace3.ml", line 28, characters 11-23
-Uncaught exception Backtrace3.Error("d")
-Raised at file "backtrace3.ml", line 7, characters 21-32
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 11, characters 4-11
-Called from file "backtrace3.ml", line 28, characters 11-23
-Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace3.ml", line 28, characters 14-22
diff --git a/testsuite/tests/backtrace/backtrace_deprecated.byte.reference b/testsuite/tests/backtrace/backtrace_deprecated.byte.reference
new file mode 100644
index 00000000..e3eee3d6
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace_deprecated.byte.reference
@@ -0,0 +1,27 @@
+a
+No exception
+b
+Uncaught exception Backtrace_deprecated.Error("b")
+Raised at file "backtrace_deprecated.ml", line 10, characters 21-32
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 14, characters 4-11
+Re-raised at file "backtrace_deprecated.ml", line 16, characters 68-71
+Called from file "backtrace_deprecated.ml", line 21, characters 11-23
+Uncaught exception Backtrace_deprecated.Error("c")
+Raised at file "backtrace_deprecated.ml", line 17, characters 26-37
+Called from file "backtrace_deprecated.ml", line 21, characters 11-23
+Uncaught exception Backtrace_deprecated.Error("d")
+Raised at file "backtrace_deprecated.ml", line 10, characters 21-32
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 14, characters 4-11
+Called from file "backtrace_deprecated.ml", line 21, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace_deprecated.ml", line 21, characters 14-22
diff --git a/testsuite/tests/backtrace/backtrace_deprecated.native.reference b/testsuite/tests/backtrace/backtrace_deprecated.native.reference
new file mode 100644
index 00000000..8d6826ec
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace_deprecated.native.reference
@@ -0,0 +1,27 @@
+a
+No exception
+b
+Uncaught exception Backtrace_deprecated.Error("b")
+Raised at file "backtrace_deprecated.ml", line 10, characters 16-32
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 14, characters 4-11
+Re-raised at file "backtrace_deprecated.ml", line 16, characters 62-71
+Called from file "backtrace_deprecated.ml", line 21, characters 11-23
+Uncaught exception Backtrace_deprecated.Error("c")
+Raised at file "backtrace_deprecated.ml", line 17, characters 20-37
+Called from file "backtrace_deprecated.ml", line 21, characters 11-23
+Uncaught exception Backtrace_deprecated.Error("d")
+Raised at file "backtrace_deprecated.ml", line 10, characters 16-32
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 14, characters 4-11
+Called from file "backtrace_deprecated.ml", line 21, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace_deprecated.ml", line 21, characters 14-22
diff --git a/testsuite/tests/backtrace/backtrace_deprecated.reference b/testsuite/tests/backtrace/backtrace_deprecated.reference
deleted file mode 100644
index e3eee3d6..00000000
--- a/testsuite/tests/backtrace/backtrace_deprecated.reference
+++ /dev/null
@@ -1,27 +0,0 @@
-a
-No exception
-b
-Uncaught exception Backtrace_deprecated.Error("b")
-Raised at file "backtrace_deprecated.ml", line 10, characters 21-32
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 14, characters 4-11
-Re-raised at file "backtrace_deprecated.ml", line 16, characters 68-71
-Called from file "backtrace_deprecated.ml", line 21, characters 11-23
-Uncaught exception Backtrace_deprecated.Error("c")
-Raised at file "backtrace_deprecated.ml", line 17, characters 26-37
-Called from file "backtrace_deprecated.ml", line 21, characters 11-23
-Uncaught exception Backtrace_deprecated.Error("d")
-Raised at file "backtrace_deprecated.ml", line 10, characters 21-32
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 14, characters 4-11
-Called from file "backtrace_deprecated.ml", line 21, characters 11-23
-Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace_deprecated.ml", line 21, characters 14-22
diff --git a/testsuite/tests/backtrace/backtrace_slots.byte.reference b/testsuite/tests/backtrace/backtrace_slots.byte.reference
new file mode 100644
index 00000000..bfd8f5f4
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace_slots.byte.reference
@@ -0,0 +1,27 @@
+a
+No exception
+b
+Uncaught exception Backtrace_slots.Error("b")
+Raised at file "backtrace_slots.ml", line 36, characters 21-32
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 40, characters 4-11
+Re-raised at file "backtrace_slots.ml", line 42, characters 68-71
+Called from file "backtrace_slots.ml", line 47, characters 11-23
+Uncaught exception Backtrace_slots.Error("c")
+Raised at file "backtrace_slots.ml", line 43, characters 26-37
+Called from file "backtrace_slots.ml", line 47, characters 11-23
+Uncaught exception Backtrace_slots.Error("d")
+Raised at file "backtrace_slots.ml", line 36, characters 21-32
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 40, characters 4-11
+Called from file "backtrace_slots.ml", line 47, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace_slots.ml", line 47, characters 14-22
diff --git a/testsuite/tests/backtrace/backtrace_slots.native.reference b/testsuite/tests/backtrace/backtrace_slots.native.reference
new file mode 100644
index 00000000..dd47e69d
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace_slots.native.reference
@@ -0,0 +1,27 @@
+a
+No exception
+b
+Uncaught exception Backtrace_slots.Error("b")
+Raised at file "backtrace_slots.ml", line 36, characters 16-32
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 40, characters 4-11
+Re-raised at file "backtrace_slots.ml", line 42, characters 62-71
+Called from file "backtrace_slots.ml", line 47, characters 11-23
+Uncaught exception Backtrace_slots.Error("c")
+Raised at file "backtrace_slots.ml", line 43, characters 20-37
+Called from file "backtrace_slots.ml", line 47, characters 11-23
+Uncaught exception Backtrace_slots.Error("d")
+Raised at file "backtrace_slots.ml", line 36, characters 16-32
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 40, characters 4-11
+Called from file "backtrace_slots.ml", line 47, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace_slots.ml", line 47, characters 14-22
diff --git a/testsuite/tests/backtrace/backtrace_slots.reference b/testsuite/tests/backtrace/backtrace_slots.reference
deleted file mode 100644
index bfd8f5f4..00000000
--- a/testsuite/tests/backtrace/backtrace_slots.reference
+++ /dev/null
@@ -1,27 +0,0 @@
-a
-No exception
-b
-Uncaught exception Backtrace_slots.Error("b")
-Raised at file "backtrace_slots.ml", line 36, characters 21-32
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 40, characters 4-11
-Re-raised at file "backtrace_slots.ml", line 42, characters 68-71
-Called from file "backtrace_slots.ml", line 47, characters 11-23
-Uncaught exception Backtrace_slots.Error("c")
-Raised at file "backtrace_slots.ml", line 43, characters 26-37
-Called from file "backtrace_slots.ml", line 47, characters 11-23
-Uncaught exception Backtrace_slots.Error("d")
-Raised at file "backtrace_slots.ml", line 36, characters 21-32
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 40, characters 4-11
-Called from file "backtrace_slots.ml", line 47, characters 11-23
-Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace_slots.ml", line 47, characters 14-22
diff --git a/testsuite/tests/backtrace/backtraces_and_finalizers.native.reference b/testsuite/tests/backtrace/backtraces_and_finalizers.native.reference
new file mode 100644
index 00000000..9766475a
--- /dev/null
+++ b/testsuite/tests/backtrace/backtraces_and_finalizers.native.reference
@@ -0,0 +1 @@
+ok
diff --git a/testsuite/tests/backtrace/backtraces_and_finalizers.reference b/testsuite/tests/backtrace/backtraces_and_finalizers.reference
deleted file mode 100644
index 9766475a..00000000
--- a/testsuite/tests/backtrace/backtraces_and_finalizers.reference
+++ /dev/null
@@ -1 +0,0 @@
-ok
diff --git a/testsuite/tests/backtrace/inline_test.byte.reference b/testsuite/tests/backtrace/inline_test.byte.reference
new file mode 100644
index 00000000..0cda2efd
--- /dev/null
+++ b/testsuite/tests/backtrace/inline_test.byte.reference
@@ -0,0 +1,15 @@
+inline_test.ml
+line 5
+characters 8-24
+inline_test.ml
+line 8
+characters 2-5
+inline_test.ml
+line 11
+characters 12-17
+inline_test.ml
+line 14
+characters 5-8
+inline_test.ml
+line 18
+characters 2-6
diff --git a/testsuite/tests/backtrace/inline_test.ml b/testsuite/tests/backtrace/inline_test.ml
new file mode 100644
index 00000000..ae64e2cd
--- /dev/null
+++ b/testsuite/tests/backtrace/inline_test.ml
@@ -0,0 +1,18 @@
+
+(* A test for inlined stack backtraces *)
+
+let f x =
+  raise (Failure "test") + 1
+
+let g x =
+  f x + 1
+
+let h x =
+  print_int (g x); print_endline "h"
+
+let i x =
+  if h x = () then ()
+
+let () =
+  Printexc.record_backtrace true;
+  i ()
diff --git a/testsuite/tests/backtrace/inline_test.native.reference b/testsuite/tests/backtrace/inline_test.native.reference
new file mode 100644
index 00000000..644987b9
--- /dev/null
+++ b/testsuite/tests/backtrace/inline_test.native.reference
@@ -0,0 +1,15 @@
+inline_test.ml
+line 5
+characters 2-24
+inline_test.ml
+line 8
+characters 2-5
+inline_test.ml
+line 11
+characters 12-17
+inline_test.ml
+line 14
+characters 5-8
+inline_test.ml
+line 18
+characters 2-6
diff --git a/testsuite/tests/backtrace/inline_traversal_test.byte.reference b/testsuite/tests/backtrace/inline_traversal_test.byte.reference
new file mode 100644
index 00000000..bcb98c34
--- /dev/null
+++ b/testsuite/tests/backtrace/inline_traversal_test.byte.reference
@@ -0,0 +1,5 @@
+inline_traversal_test.ml:5
+inline_traversal_test.ml:8
+inline_traversal_test.ml:11
+inline_traversal_test.ml:14
+inline_traversal_test.ml:19
diff --git a/testsuite/tests/backtrace/inline_traversal_test.ml b/testsuite/tests/backtrace/inline_traversal_test.ml
new file mode 100644
index 00000000..1d918446
--- /dev/null
+++ b/testsuite/tests/backtrace/inline_traversal_test.ml
@@ -0,0 +1,46 @@
+
+(* A test for inlined stack backtraces *)
+
+let f x =
+  raise (Failure "test") + 1
+
+let g x =
+  f x + 1
+
+let h x =
+  print_int (g x); print_endline "h"
+
+let i x =
+  if h x = () then ()
+
+let () =
+  let open Printexc in
+  record_backtrace true;
+  try i ()
+  with _ ->
+    let trace = get_raw_backtrace () in
+    let print_slot slot =
+      let x = convert_raw_backtrace_slot slot in
+      let is_raise = Slot.is_raise x in
+      let is_inline = Slot.is_inline x in
+      let location = match Slot.location x with
+        | None -> ""
+        | Some {filename; line_number; _} ->
+            filename ^ ":" ^ string_of_int line_number
+      in
+      Printf.printf "- %s%s%s\n"
+        location
+        (if is_inline then " inlined" else "")
+        (if is_raise then ", raise" else "")
+    in
+    let rec print_slots = function
+      | None -> ()
+      | Some slot ->
+        print_slot slot;
+        print_slots (get_raw_backtrace_next_slot slot)
+    in
+    for i = 0 to raw_backtrace_length trace - 1 do
+      let slot = get_raw_backtrace_slot trace i in
+      Printf.printf "Frame %d\n" i;
+      print_slots (Some slot)
+    done
diff --git a/testsuite/tests/backtrace/inline_traversal_test.native.reference b/testsuite/tests/backtrace/inline_traversal_test.native.reference
new file mode 100644
index 00000000..bcb98c34
--- /dev/null
+++ b/testsuite/tests/backtrace/inline_traversal_test.native.reference
@@ -0,0 +1,5 @@
+inline_traversal_test.ml:5
+inline_traversal_test.ml:8
+inline_traversal_test.ml:11
+inline_traversal_test.ml:14
+inline_traversal_test.ml:19
diff --git a/testsuite/tests/backtrace/pr6920_why_at.byte.reference b/testsuite/tests/backtrace/pr6920_why_at.byte.reference
new file mode 100644
index 00000000..dcc2fcc1
--- /dev/null
+++ b/testsuite/tests/backtrace/pr6920_why_at.byte.reference
@@ -0,0 +1,4 @@
+Fatal error: exception Pervasives.Exit
+Raised at file "pr6920_why_at.ml", line 1, characters 41-45
+Called from file "pr6920_why_at.ml", line 3, characters 2-11
+Called from file "pr6920_why_at.ml", line 9, characters 2-6
diff --git a/testsuite/tests/backtrace/pr6920_why_at.native.reference b/testsuite/tests/backtrace/pr6920_why_at.native.reference
new file mode 100644
index 00000000..057c3895
--- /dev/null
+++ b/testsuite/tests/backtrace/pr6920_why_at.native.reference
@@ -0,0 +1,4 @@
+Fatal error: exception Pervasives.Exit
+Raised at file "pr6920_why_at.ml", line 1, characters 35-45
+Called from file "pr6920_why_at.ml", line 3, characters 2-11
+Called from file "pr6920_why_at.ml", line 9, characters 2-6
diff --git a/testsuite/tests/backtrace/pr6920_why_at.reference b/testsuite/tests/backtrace/pr6920_why_at.reference
deleted file mode 100644
index dcc2fcc1..00000000
--- a/testsuite/tests/backtrace/pr6920_why_at.reference
+++ /dev/null
@@ -1,4 +0,0 @@
-Fatal error: exception Pervasives.Exit
-Raised at file "pr6920_why_at.ml", line 1, characters 41-45
-Called from file "pr6920_why_at.ml", line 3, characters 2-11
-Called from file "pr6920_why_at.ml", line 9, characters 2-6
diff --git a/testsuite/tests/backtrace/pr6920_why_swallow.byte.reference b/testsuite/tests/backtrace/pr6920_why_swallow.byte.reference
new file mode 100644
index 00000000..ad66532f
--- /dev/null
+++ b/testsuite/tests/backtrace/pr6920_why_swallow.byte.reference
@@ -0,0 +1,4 @@
+Fatal error: exception Pervasives.Exit
+Raised at file "pr6920_why_swallow.ml", line 1, characters 41-45
+Called from file "pr6920_why_swallow.ml", line 4, characters 4-14
+Called from file "pr6920_why_swallow.ml", line 11, characters 2-6
diff --git a/testsuite/tests/backtrace/pr6920_why_swallow.native.reference b/testsuite/tests/backtrace/pr6920_why_swallow.native.reference
new file mode 100644
index 00000000..facb06dd
--- /dev/null
+++ b/testsuite/tests/backtrace/pr6920_why_swallow.native.reference
@@ -0,0 +1,4 @@
+Fatal error: exception Pervasives.Exit
+Raised at file "pr6920_why_swallow.ml", line 1, characters 35-45
+Called from file "pr6920_why_swallow.ml", line 4, characters 4-14
+Called from file "pr6920_why_swallow.ml", line 11, characters 2-6
diff --git a/testsuite/tests/backtrace/pr6920_why_swallow.reference b/testsuite/tests/backtrace/pr6920_why_swallow.reference
deleted file mode 100644
index ad66532f..00000000
--- a/testsuite/tests/backtrace/pr6920_why_swallow.reference
+++ /dev/null
@@ -1,4 +0,0 @@
-Fatal error: exception Pervasives.Exit
-Raised at file "pr6920_why_swallow.ml", line 1, characters 41-45
-Called from file "pr6920_why_swallow.ml", line 4, characters 4-14
-Called from file "pr6920_why_swallow.ml", line 11, characters 2-6
diff --git a/testsuite/tests/backtrace/raw_backtrace.byte.reference b/testsuite/tests/backtrace/raw_backtrace.byte.reference
new file mode 100644
index 00000000..b9365231
--- /dev/null
+++ b/testsuite/tests/backtrace/raw_backtrace.byte.reference
@@ -0,0 +1,27 @@
+a
+No exception
+b
+Uncaught exception Raw_backtrace.Error("b")
+Raised at file "raw_backtrace.ml", line 7, characters 21-32
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 11, characters 4-11
+Re-raised at file "raw_backtrace.ml", line 13, characters 68-71
+Called from file "raw_backtrace.ml", line 18, characters 11-23
+Uncaught exception Raw_backtrace.Error("c")
+Raised at file "raw_backtrace.ml", line 14, characters 26-37
+Called from file "raw_backtrace.ml", line 18, characters 11-23
+Uncaught exception Raw_backtrace.Error("d")
+Raised at file "raw_backtrace.ml", line 7, characters 21-32
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 11, characters 4-11
+Called from file "raw_backtrace.ml", line 18, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "raw_backtrace.ml", line 18, characters 14-22
diff --git a/testsuite/tests/backtrace/raw_backtrace.native.reference b/testsuite/tests/backtrace/raw_backtrace.native.reference
new file mode 100644
index 00000000..b1ff607c
--- /dev/null
+++ b/testsuite/tests/backtrace/raw_backtrace.native.reference
@@ -0,0 +1,27 @@
+a
+No exception
+b
+Uncaught exception Raw_backtrace.Error("b")
+Raised at file "raw_backtrace.ml", line 7, characters 16-32
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 11, characters 4-11
+Re-raised at file "raw_backtrace.ml", line 13, characters 62-71
+Called from file "raw_backtrace.ml", line 18, characters 11-23
+Uncaught exception Raw_backtrace.Error("c")
+Raised at file "raw_backtrace.ml", line 14, characters 20-37
+Called from file "raw_backtrace.ml", line 18, characters 11-23
+Uncaught exception Raw_backtrace.Error("d")
+Raised at file "raw_backtrace.ml", line 7, characters 16-32
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 11, characters 4-11
+Called from file "raw_backtrace.ml", line 18, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "raw_backtrace.ml", line 18, characters 14-22
diff --git a/testsuite/tests/backtrace/raw_backtrace.reference b/testsuite/tests/backtrace/raw_backtrace.reference
deleted file mode 100644
index b9365231..00000000
--- a/testsuite/tests/backtrace/raw_backtrace.reference
+++ /dev/null
@@ -1,27 +0,0 @@
-a
-No exception
-b
-Uncaught exception Raw_backtrace.Error("b")
-Raised at file "raw_backtrace.ml", line 7, characters 21-32
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 11, characters 4-11
-Re-raised at file "raw_backtrace.ml", line 13, characters 68-71
-Called from file "raw_backtrace.ml", line 18, characters 11-23
-Uncaught exception Raw_backtrace.Error("c")
-Raised at file "raw_backtrace.ml", line 14, characters 26-37
-Called from file "raw_backtrace.ml", line 18, characters 11-23
-Uncaught exception Raw_backtrace.Error("d")
-Raised at file "raw_backtrace.ml", line 7, characters 21-32
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 11, characters 4-11
-Called from file "raw_backtrace.ml", line 18, characters 11-23
-Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "raw_backtrace.ml", line 18, characters 14-22
diff --git a/testsuite/tests/basic-float/Makefile b/testsuite/tests/basic-float/Makefile
index a3fd7f64..c11a415f 100644
--- a/testsuite/tests/basic-float/Makefile
+++ b/testsuite/tests/basic-float/Makefile
@@ -14,8 +14,5 @@
 #**************************************************************************
 
 BASEDIR=../..
-MODULES=float_record float_array
-MAIN_MODULE=tfloat_record
-
-include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.several
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/basic-float/float_array.ml b/testsuite/tests/basic-float/float_array.ml
deleted file mode 100644
index 8ec63b09..00000000
--- a/testsuite/tests/basic-float/float_array.ml
+++ /dev/null
@@ -1,8 +0,0 @@
-let small_float_array x =
-  [|1.;2.;3.|], x
-
-let longer_float_array x =
-  [|1.;2.;3.;4.;5.;6.;7.;8.;9.;0.;
-    1.;2.;3.;4.;5.;6.;7.;8.;9.;0.;
-    1.;2.;3.;4.;5.;6.;7.;8.;9.;0.;
-    1.;2.;3.;4.;5.;6.;7.;8.;9.;0.;|], x
diff --git a/testsuite/tests/basic-float/float_record.ml b/testsuite/tests/basic-float/float_record.ml
deleted file mode 100644
index 6bbbd3fb..00000000
--- a/testsuite/tests/basic-float/float_record.ml
+++ /dev/null
@@ -1,22 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*              Pierre Weis, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-type t = float;;
-
-let make f = f;;
-
-let from t = t;;
-
-type s = {f : t};;
diff --git a/testsuite/tests/basic-float/float_record.mli b/testsuite/tests/basic-float/float_record.mli
deleted file mode 100644
index b3f69ae5..00000000
--- a/testsuite/tests/basic-float/float_record.mli
+++ /dev/null
@@ -1,21 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*              Pierre Weis, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-type t = private float;;
-
-val make : float -> t;;
-val from : t -> float;;
-
-type s = {f : t};;
diff --git a/testsuite/tests/basic-float/tfloat_hex.ml b/testsuite/tests/basic-float/tfloat_hex.ml
new file mode 100644
index 00000000..995d50c2
--- /dev/null
+++ b/testsuite/tests/basic-float/tfloat_hex.ml
@@ -0,0 +1,15 @@
+let try_float_of_string str =
+  try
+    print_float (float_of_string str);
+    print_newline ()
+  with exn ->
+    print_endline (Printexc.to_string exn)
+;;
+
+let () =
+  try_float_of_string "0x1A";
+  try_float_of_string "0x1Ap3";
+  try_float_of_string "0x";
+  try_float_of_string "0x.";
+  try_float_of_string "0xp0";
+  try_float_of_string "0x.p0";
diff --git a/testsuite/tests/basic-float/tfloat_hex.reference b/testsuite/tests/basic-float/tfloat_hex.reference
new file mode 100644
index 00000000..9fce15f2
--- /dev/null
+++ b/testsuite/tests/basic-float/tfloat_hex.reference
@@ -0,0 +1,6 @@
+26.
+208.
+Failure("float_of_string")
+Failure("float_of_string")
+Failure("float_of_string")
+Failure("float_of_string")
diff --git a/testsuite/tests/basic-float/tfloat_record.ml b/testsuite/tests/basic-float/tfloat_record.ml
index 12ab9a52..38cf230b 100644
--- a/testsuite/tests/basic-float/tfloat_record.ml
+++ b/testsuite/tests/basic-float/tfloat_record.ml
@@ -1,17 +1,30 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*              Pierre Weis, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
+module Float_record : sig
+  type t = private float;;
+
+  val make : float -> t;;
+  val from : t -> float;;
+
+  type s = {f : t};;
+end = struct
+  type t = float;;
+
+  let make f = f;;
+
+  let from t = t;;
+
+  type s = {f : t};;
+end
+
+module Float_array = struct
+  let small_float_array x =
+    [|1.;2.;3.|], x
+
+  let longer_float_array x =
+    [|1.;2.;3.;4.;5.;6.;7.;8.;9.;0.;
+      1.;2.;3.;4.;5.;6.;7.;8.;9.;0.;
+      1.;2.;3.;4.;5.;6.;7.;8.;9.;0.;
+      1.;2.;3.;4.;5.;6.;7.;8.;9.;0.;|], x
+end
 
 let s = { Float_record.f = Float_record.make 1.0 };;
 
diff --git a/testsuite/tests/basic-io-2/io.ml b/testsuite/tests/basic-io-2/io.ml
index bad6c4f4..3c088d3f 100644
--- a/testsuite/tests/basic-io-2/io.ml
+++ b/testsuite/tests/basic-io-2/io.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Test a file copy function *)
 
 let test msg funct f1 f2 =
diff --git a/testsuite/tests/basic-manyargs/manyargs.ml b/testsuite/tests/basic-manyargs/manyargs.ml
index f8b39ad1..352f3cfa 100644
--- a/testsuite/tests/basic-manyargs/manyargs.ml
+++ b/testsuite/tests/basic-manyargs/manyargs.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1995 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let manyargs a b c d e f g h i j k l m n o =
   print_string "a = "; print_int a; print_newline();
   print_string "b = "; print_int b; print_newline();
diff --git a/testsuite/tests/basic-modules/main.ml b/testsuite/tests/basic-modules/main.ml
index d49acbd3..7f3f44d7 100644
--- a/testsuite/tests/basic-modules/main.ml
+++ b/testsuite/tests/basic-modules/main.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*               Jacques Garrigue, Nagoya University                      *)
-(*                                                                        *)
-(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* PR#6435 *)
 
 module F (M : sig
diff --git a/testsuite/tests/basic-modules/offset.ml b/testsuite/tests/basic-modules/offset.ml
index 0b2a8d6f..457947dc 100644
--- a/testsuite/tests/basic-modules/offset.ml
+++ b/testsuite/tests/basic-modules/offset.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*               Jacques Garrigue, Nagoya University                      *)
-(*                                                                        *)
-(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 module M = struct
  type t = string
 
diff --git a/testsuite/tests/basic-modules/pr6726.ml b/testsuite/tests/basic-modules/pr6726.ml
index 16d12b1e..7b503501 100644
--- a/testsuite/tests/basic-modules/pr6726.ml
+++ b/testsuite/tests/basic-modules/pr6726.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*               Jacques Garrigue, Nagoya University                      *)
-(*                                                                        *)
-(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 module ExtUnixAll = struct
  external unused : unit -> unit = "caml_blit_string"
  module BigEndian = struct
diff --git a/testsuite/tests/basic-more/bounds.ml b/testsuite/tests/basic-more/bounds.ml
index 4285964b..edaa0c8a 100644
--- a/testsuite/tests/basic-more/bounds.ml
+++ b/testsuite/tests/basic-more/bounds.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1998 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Test bound checks with ocamlopt *)
 
 let a = [| 0; 1; 2 |]
diff --git a/testsuite/tests/basic-more/div_by_zero.ml b/testsuite/tests/basic-more/div_by_zero.ml
new file mode 100644
index 00000000..9dc45e7b
--- /dev/null
+++ b/testsuite/tests/basic-more/div_by_zero.ml
@@ -0,0 +1,67 @@
+
+let check f n =
+  assert (
+    try ignore ((Sys.opaque_identity f) n); false with
+      Division_by_zero -> true
+  )
+
+let div_int n  = n / 0
+let div_int32 n = Int32.div n 0l
+let div_int64 n = Int64.div n 0L
+let div_nativeint n = Nativeint.div n 0n
+
+let mod_int n  = n mod 0
+let mod_int32 n = Int32.rem n 0l
+let mod_int64 n = Int64.rem n 0L
+let mod_nativeint n = Nativeint.rem n 0n
+
+let div_int_opaque n  = n / (Sys.opaque_identity 0)
+let div_int32_opaque n = Int32.div n (Sys.opaque_identity 0l)
+let div_int64_opaque n = Int64.div n (Sys.opaque_identity 0L)
+let div_nativeint_opaque n = Nativeint.div n (Sys.opaque_identity 0n)
+
+let mod_int_opaque n  = n mod (Sys.opaque_identity 0)
+let mod_int32_opaque n = Int32.rem n (Sys.opaque_identity 0l)
+let mod_int64_opaque n = Int64.rem n (Sys.opaque_identity 0L)
+let mod_nativeint_opaque n = Nativeint.rem n (Sys.opaque_identity 0n)
+
+let () =
+  check div_int 33;
+  check div_int 0;
+  check div_int32 33l;
+  check div_int32 0l;
+  check div_int64 33L;
+  check div_int64 0L;
+  check div_nativeint 33n;
+  check div_nativeint 0n;
+
+  check mod_int 33;
+  check mod_int 0;
+  check mod_int32 33l;
+  check mod_int32 0l;
+  check mod_int64 33L;
+  check mod_int64 0L;
+  check mod_nativeint 33n;
+  check mod_nativeint 0n;
+
+  check div_int_opaque 33;
+  check div_int_opaque 0;
+  check div_int32_opaque 33l;
+  check div_int32_opaque 0l;
+  check div_int64_opaque 33L;
+  check div_int64_opaque 0L;
+  check div_nativeint_opaque 33n;
+  check div_nativeint_opaque 0n;
+
+  check mod_int_opaque 33;
+  check mod_int_opaque 0;
+  check mod_int32_opaque 33l;
+  check mod_int32_opaque 0l;
+  check mod_int64_opaque 33L;
+  check mod_int64_opaque 0L;
+  check mod_nativeint_opaque 33n;
+  check mod_nativeint_opaque 0n;
+  ()
+
+let () =
+  print_endline "***** OK *****"
diff --git a/testsuite/tests/basic-more/div_by_zero.reference b/testsuite/tests/basic-more/div_by_zero.reference
new file mode 100644
index 00000000..e6b95628
--- /dev/null
+++ b/testsuite/tests/basic-more/div_by_zero.reference
@@ -0,0 +1,3 @@
+***** OK *****
+
+All tests succeeded.
diff --git a/testsuite/tests/basic-more/morematch.ml b/testsuite/tests/basic-more/morematch.ml
index 7c5eb502..86b63882 100644
--- a/testsuite/tests/basic-more/morematch.ml
+++ b/testsuite/tests/basic-more/morematch.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Luc Maranget, projet Moscova, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2001 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (**************************************************************)
 (*  This suite tests the pattern-matching compiler            *)
 (*  it should just compile and run.                           *)
diff --git a/testsuite/tests/basic-more/pr2719.ml b/testsuite/tests/basic-more/pr2719.ml
index fc8fd883..f0a9d6a4 100644
--- a/testsuite/tests/basic-more/pr2719.ml
+++ b/testsuite/tests/basic-more/pr2719.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed 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 Printf
 
 let bug () =
diff --git a/testsuite/tests/basic-more/pr6216.ml b/testsuite/tests/basic-more/pr6216.ml
index 97670487..71844f14 100644
--- a/testsuite/tests/basic-more/pr6216.ml
+++ b/testsuite/tests/basic-more/pr6216.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*               Jacques Garrigue, Nagoya University                      *)
-(*                                                                        *)
-(*   Copyright 2013 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* PR6216: wrong inlining of GADT match *)
 
 type _ t =
diff --git a/testsuite/tests/basic-more/record_evaluation_order.ml b/testsuite/tests/basic-more/record_evaluation_order.ml
new file mode 100644
index 00000000..0e18af8c
--- /dev/null
+++ b/testsuite/tests/basic-more/record_evaluation_order.ml
@@ -0,0 +1,89 @@
+
+type r =
+  { a : unit;
+    b : int;
+    c : char;
+    d : float; }
+
+let r1 =
+  {
+    c = (print_endline "c1"; 'c');
+    a = print_endline "a1";
+    d = (print_endline "d1"; 1.);
+    b = (print_endline "b1"; 2);
+  }
+
+let r2 =
+  {
+    b = (print_endline "b2"; 2);
+    d = (print_endline "d2"; 1.);
+    a = print_endline "a2";
+    c = (print_endline "c2"; 'c');
+  }
+
+let r3 =
+  { (print_endline "default"; r1) with
+    d = (print_endline "d3"; 1.);
+    c = (print_endline "c3"; 'c');
+    a = print_endline "a3";
+  }
+
+let () = print_endline ""
+
+type r2 =
+  { x1 : unit;
+    x2 : unit;
+    x3 : unit;
+    x4 : unit;
+    x5 : unit;
+    x6 : unit;
+    x7 : unit;
+    x8 : unit;
+    x9 : unit; }
+
+let a =
+  {
+    x5 = print_endline "x5";
+    x6 = print_endline "x6";
+    x1 = print_endline "x1";
+    x3 = print_endline "x3";
+    x4 = print_endline "x4";
+    x9 = print_endline "x9";
+    x7 = print_endline "x7";
+    x8 = print_endline "x8";
+    x2 = print_endline "x2";
+  }
+
+let () = print_endline ""
+
+let b =
+  { a with
+    x7 = print_endline "x7";
+    x2 = print_endline "x2";
+  }
+
+let () = print_endline ""
+
+let c =
+  { a with
+    x2 = print_endline "x2";
+    x7 = print_endline "x7";
+  }
+
+let () = print_endline ""
+
+let c =
+  { a with
+    x2 = print_endline "x2";
+    x7 = print_endline "x7";
+    x5 = print_endline "x5";
+  }
+
+let () = print_endline ""
+
+let d =
+  { a with
+    x5 = print_endline "x5";
+    x7 = print_endline "x7";
+    x2 = print_endline "x2";
+  }
diff --git a/testsuite/tests/basic-more/record_evaluation_order.reference b/testsuite/tests/basic-more/record_evaluation_order.reference
new file mode 100644
index 00000000..f4186851
--- /dev/null
+++ b/testsuite/tests/basic-more/record_evaluation_order.reference
@@ -0,0 +1,38 @@
+d1
+c1
+b1
+a1
+d2
+c2
+b2
+a2
+default
+d3
+c3
+a3
+
+x9
+x8
+x7
+x6
+x5
+x4
+x3
+x2
+x1
+
+x7
+x2
+
+x7
+x2
+
+x7
+x5
+x2
+
+x7
+x5
+x2
+
+All tests succeeded.
diff --git a/testsuite/tests/basic-more/sequential_and_or.ml b/testsuite/tests/basic-more/sequential_and_or.ml
index 6218b560..6492ea27 100644
--- a/testsuite/tests/basic-more/sequential_and_or.ml
+++ b/testsuite/tests/basic-more/sequential_and_or.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                       Pierre Chambart, OCamlPro                        *)
-(*                                                                        *)
-(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed 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 r = ref 0
 
 let true_effect () =
@@ -36,10 +21,10 @@ let () =
   s.[0] <- '\001'
 
 let unknown_true =
-  s.[0] = '\001'
+  Bytes.get s 0 = '\001'
 
 let unknown_false =
-  s.[0] <> '\001'
+  Bytes.get s 0 <> '\001'
 
 let () =
   test 1 (fun () -> true || true);
diff --git a/testsuite/tests/basic-more/structural_constants.ml b/testsuite/tests/basic-more/structural_constants.ml
new file mode 100644
index 00000000..4249e8c6
--- /dev/null
+++ b/testsuite/tests/basic-more/structural_constants.ml
@@ -0,0 +1,217 @@
+
+type t1 =
+  | A | B | C of t1 | D of float
+
+let a = [A; B; C A; C (C A); D 1.234]
+let () =
+  match Sys.opaque_identity a with
+  | [A; B; C A; C (C A); D 1.234] -> ()
+  | _ -> assert false
+
+let () =
+  match a with
+  | [A; B; C A; C (C A); D 1.234] -> ()
+  | _ -> assert false
+
+let b = [|A; B; C A; C (C A); D 1.234|]
+let () =
+  match Sys.opaque_identity b with
+  | [|A; B; C A; C (C A); D 1.234|] -> ()
+  | _ -> assert false
+
+let () =
+  match b with
+  | [|A; B; C A; C (C A); D 1.234|] -> ()
+  | _ -> assert false
+
+let c = [1.; 2.]
+let () =
+  match Sys.opaque_identity c with
+  | [1.; 2.] -> ()
+  | _ -> assert false
+
+let () =
+  match c with
+  | [1.; 2.] -> ()
+  | _ -> assert false
+
+let d = [|1.; 2.|]
+let () =
+  match Sys.opaque_identity d with
+  | [|1.; 2.|] -> ()
+  | _ -> assert false
+
+let () =
+  match d with
+  | [|1.; 2.|] -> ()
+  | _ -> assert false
+
+let long_array =
+  [|0; 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; 33; 34; 35; 36; 37; 38;
+    39; 40; 41; 42; 43; 44; 45; 46; 47; 48; 49; 50; 51;
+    52; 53; 54; 55; 56; 57; 58; 59; 60; 61; 62; 63; 64;
+    65; 66; 67; 68; 69; 70; 71; 72; 73; 74; 75; 76; 77;
+    78; 79; 80; 81; 82; 83; 84; 85; 86; 87; 88; 89; 90;
+    91; 92; 93; 94; 95; 96; 97; 98; 99; 100; 101; 102; 103;
+    104; 105; 106; 107; 108; 109; 110; 111; 112; 113; 114; 115; 116;
+    117; 118; 119; 120; 121; 122; 123; 124; 125; 126; 127; 128; 129;
+    130; 131; 132; 133; 134; 135; 136; 137; 138; 139; 140; 141; 142;
+    143; 144; 145; 146; 147; 148; 149; 150; 151; 152; 153; 154; 155;
+    156; 157; 158; 159; 160; 161; 162; 163; 164; 165; 166; 167; 168;
+    169; 170; 171; 172; 173; 174; 175; 176; 177; 178; 179; 180; 181;
+    182; 183; 184; 185; 186; 187; 188; 189; 190; 191; 192; 193; 194;
+    195; 196; 197; 198; 199; 200; 201; 202; 203; 204; 205; 206; 207;
+    208; 209; 210; 211; 212; 213; 214; 215; 216; 217; 218; 219; 220;
+    221; 222; 223; 224; 225; 226; 227; 228; 229; 230; 231; 232; 233;
+    234; 235; 236; 237; 238; 239; 240; 241; 242; 243; 244; 245; 246;
+    247; 248; 249; 250; 251; 252; 253; 254; 255; 256; 257; 258; 259;
+    260; 261; 262; 263; 264; 265; 266; 267; 268; 269; 270; 271; 272;
+    273; 274; 275; 276; 277; 278; 279; 280; 281; 282; 283; 284; 285;
+    286; 287; 288; 289; 290; 291; 292; 293; 294; 295; 296; 297; 298;
+    299; 300; 301; 302; 303; 304; 305; 306; 307; 308; 309; 310; 311;
+    312; 313; 314; 315; 316; 317; 318; 319; 320; 321; 322; 323; 324;
+    325; 326; 327; 328; 329; 330; 331; 332; 333; 334; 335; 336; 337;
+    338; 339; 340; 341; 342; 343; 344; 345; 346; 347; 348; 349; 350;
+    351; 352; 353; 354; 355; 356; 357; 358; 359; 360; 361; 362; 363;
+    364; 365; 366; 367; 368; 369; 370; 371; 372; 373; 374; 375; 376;
+    377; 378; 379; 380; 381; 382; 383; 384; 385; 386; 387; 388; 389;
+    390; 391; 392; 393; 394; 395; 396; 397; 398; 399; 400; 401; 402;
+    403; 404; 405; 406; 407; 408; 409; 410; 411; 412; 413; 414; 415;
+    416; 417; 418; 419; 420; 421; 422; 423; 424; 425; 426; 427; 428;
+    429; 430; 431; 432; 433; 434; 435; 436; 437; 438; 439; 440; 441;
+    442; 443; 444; 445; 446; 447; 448; 449; 450; 451; 452; 453; 454;
+    455; 456; 457; 458; 459; 460; 461; 462; 463; 464; 465; 466; 467;
+    468; 469; 470; 471; 472; 473; 474; 475; 476; 477; 478; 479; 480;
+    481; 482; 483; 484; 485; 486; 487; 488; 489; 490; 491; 492; 493;
+    494; 495; 496; 497; 498; 499; 500; 501; 502; 503; 504; 505; 506;
+    507; 508; 509; 510; 511; 512; 513; 514; 515; 516; 517; 518; 519;
+    520; 521; 522; 523; 524; 525; 526; 527; 528; 529; 530; 531; 532;
+    533; 534; 535; 536; 537; 538; 539; 540; 541; 542; 543; 544; 545;
+    546; 547; 548; 549; 550; 551; 552; 553; 554; 555; 556; 557; 558;
+    559; 560; 561; 562; 563; 564; 565; 566; 567; 568; 569; 570; 571;
+    572; 573; 574; 575; 576; 577; 578; 579; 580; 581; 582; 583; 584;
+    585; 586; 587; 588; 589; 590; 591; 592; 593; 594; 595; 596; 597;
+    598; 599; 600; 601; 602; 603; 604; 605; 606; 607; 608; 609; 610;
+    611; 612; 613; 614; 615; 616; 617; 618; 619; 620; 621; 622; 623;
+    624; 625; 626; 627; 628; 629; 630; 631; 632; 633; 634; 635; 636;
+    637; 638; 639; 640; 641; 642; 643; 644; 645; 646; 647; 648; 649;
+    650; 651; 652; 653; 654; 655; 656; 657; 658; 659; 660; 661; 662;
+    663; 664; 665; 666; 667; 668; 669; 670; 671; 672; 673; 674; 675;
+    676; 677; 678; 679; 680; 681; 682; 683; 684; 685; 686; 687; 688;
+    689; 690; 691; 692; 693; 694; 695; 696; 697; 698; 699; 700; 701;
+    702; 703; 704; 705; 706; 707; 708; 709; 710; 711; 712; 713; 714;
+    715; 716; 717; 718; 719; 720; 721; 722; 723; 724; 725; 726; 727;
+    728; 729; 730; 731; 732; 733; 734; 735; 736; 737; 738; 739; 740;
+    741; 742; 743; 744; 745; 746; 747; 748; 749; 750; 751; 752; 753;
+    754; 755; 756; 757; 758; 759; 760; 761; 762; 763; 764; 765; 766;
+    767; 768; 769; 770; 771; 772; 773; 774; 775; 776; 777; 778; 779;
+    780; 781; 782; 783; 784; 785; 786; 787; 788; 789; 790; 791; 792;
+    793; 794; 795; 796; 797; 798; 799; 800; 801; 802; 803; 804; 805;
+    806; 807; 808; 809; 810; 811; 812; 813; 814; 815; 816; 817; 818;
+    819; 820; 821; 822; 823; 824; 825; 826; 827; 828; 829; 830; 831;
+    832; 833; 834; 835; 836; 837; 838; 839; 840; 841; 842; 843; 844;
+    845; 846; 847; 848; 849; 850; 851; 852; 853; 854; 855; 856; 857;
+    858; 859; 860; 861; 862; 863; 864; 865; 866; 867; 868; 869; 870;
+    871; 872; 873; 874; 875; 876; 877; 878; 879; 880; 881; 882; 883;
+    884; 885; 886; 887; 888; 889; 890; 891; 892; 893; 894; 895; 896;
+    897; 898; 899; 900; 901; 902; 903; 904; 905; 906; 907; 908; 909;
+    910; 911; 912; 913; 914; 915; 916; 917; 918; 919; 920; 921; 922;
+    923; 924; 925; 926; 927; 928; 929; 930; 931; 932; 933; 934; 935;
+    936; 937; 938; 939; 940; 941; 942; 943; 944; 945; 946; 947; 948;
+    949; 950; 951; 952; 953; 954; 955; 956; 957; 958; 959; 960; 961;
+    962; 963; 964; 965; 966; 967; 968; 969; 970; 971; 972; 973; 974;
+    975; 976; 977; 978; 979; 980; 981; 982; 983; 984; 985; 986; 987;
+    988; 989; 990; 991; 992; 993; 994; 995; 996; 997; 998; 999; 1000;
+    1001; 1002; 1003; 1004; 1005; 1006; 1007; 1008; 1009; 1010; 1011; 1012; 1013;
+    1014; 1015; 1016; 1017; 1018; 1019; 1020; 1021; 1022; 1023; 1024; 1025; 1026;
+    1027; 1028; 1029; 1030; 1031; 1032; 1033; 1034; 1035; 1036; 1037; 1038; 1039;
+    1040; 1041; 1042; 1043; 1044; 1045; 1046; 1047; 1048; 1049; 1050; 1051; 1052;
+    1053; 1054; 1055; 1056; 1057; 1058; 1059; 1060; 1061; 1062; 1063; 1064; 1065;
+    1066; 1067; 1068; 1069; 1070; 1071; 1072; 1073; 1074; 1075; 1076; 1077; 1078;
+    1079; 1080; 1081; 1082; 1083; 1084; 1085; 1086; 1087; 1088; 1089; 1090; 1091;
+    1092; 1093; 1094; 1095; 1096; 1097; 1098; 1099; 1100; 1101; 1102; 1103; 1104;
+    1105; 1106; 1107; 1108; 1109; 1110; 1111; 1112; 1113; 1114; 1115; 1116; 1117;
+    1118; 1119; 1120; 1121; 1122; 1123; 1124; 1125; 1126; 1127; 1128; 1129; 1130;
+    1131; 1132; 1133; 1134; 1135; 1136; 1137; 1138; 1139; 1140; 1141; 1142; 1143;
+    1144; 1145; 1146; 1147; 1148; 1149; 1150; 1151; 1152; 1153; 1154; 1155; 1156;
+    1157; 1158; 1159; 1160; 1161; 1162; 1163; 1164; 1165; 1166; 1167; 1168; 1169;
+    1170; 1171; 1172; 1173; 1174; 1175; 1176; 1177; 1178; 1179; 1180; 1181; 1182;
+    1183; 1184; 1185; 1186; 1187; 1188; 1189; 1190; 1191; 1192; 1193; 1194; 1195;
+    1196; 1197; 1198; 1199; 1200; 1201; 1202; 1203; 1204; 1205; 1206; 1207; 1208;
+    1209; 1210; 1211; 1212; 1213; 1214; 1215; 1216; 1217; 1218; 1219; 1220; 1221;
+    1222; 1223; 1224; 1225; 1226; 1227; 1228; 1229; 1230; 1231; 1232; 1233; 1234;
+    1235; 1236; 1237; 1238; 1239; 1240; 1241; 1242; 1243; 1244; 1245; 1246; 1247;
+    1248; 1249; 1250; 1251; 1252; 1253; 1254; 1255; 1256; 1257; 1258; 1259; 1260;
+    1261; 1262; 1263; 1264; 1265; 1266; 1267; 1268; 1269; 1270; 1271; 1272; 1273;
+    1274; 1275; 1276; 1277; 1278; 1279; 1280; 1281; 1282; 1283; 1284; 1285; 1286;
+    1287; 1288; 1289; 1290; 1291; 1292; 1293; 1294; 1295; 1296; 1297; 1298; 1299;
+    1300; 1301; 1302; 1303; 1304; 1305; 1306; 1307; 1308; 1309; 1310; 1311; 1312;
+    1313; 1314; 1315; 1316; 1317; 1318; 1319; 1320; 1321; 1322; 1323; 1324; 1325;
+    1326; 1327; 1328; 1329; 1330; 1331; 1332; 1333; 1334; 1335; 1336; 1337; 1338;
+    1339; 1340; 1341; 1342; 1343; 1344; 1345; 1346; 1347; 1348; 1349; 1350; 1351;
+    1352; 1353; 1354; 1355; 1356; 1357; 1358; 1359; 1360; 1361; 1362; 1363; 1364;
+    1365; 1366; 1367; 1368; 1369; 1370; 1371; 1372; 1373; 1374; 1375; 1376; 1377;
+    1378; 1379; 1380; 1381; 1382; 1383; 1384; 1385; 1386; 1387; 1388; 1389; 1390;
+    1391; 1392; 1393; 1394; 1395; 1396; 1397; 1398; 1399; 1400; 1401; 1402; 1403;
+    1404; 1405; 1406; 1407; 1408; 1409; 1410; 1411; 1412; 1413; 1414; 1415; 1416;
+    1417; 1418; 1419; 1420; 1421; 1422; 1423; 1424; 1425; 1426; 1427; 1428; 1429;
+    1430; 1431; 1432; 1433; 1434; 1435; 1436; 1437; 1438; 1439; 1440; 1441; 1442;
+    1443; 1444; 1445; 1446; 1447; 1448; 1449; 1450; 1451; 1452; 1453; 1454; 1455;
+    1456; 1457; 1458; 1459; 1460; 1461; 1462; 1463; 1464; 1465; 1466; 1467; 1468;
+    1469; 1470; 1471; 1472; 1473; 1474; 1475; 1476; 1477; 1478; 1479; 1480; 1481;
+    1482; 1483; 1484; 1485; 1486; 1487; 1488; 1489; 1490; 1491; 1492; 1493; 1494;
+    1495; 1496; 1497; 1498; 1499; 1500; 1501; 1502; 1503; 1504; 1505; 1506; 1507;
+    1508; 1509; 1510; 1511; 1512; 1513; 1514; 1515; 1516; 1517; 1518; 1519; 1520;
+    1521; 1522; 1523; 1524; 1525; 1526; 1527; 1528; 1529; 1530; 1531; 1532; 1533;
+    1534; 1535; 1536; 1537; 1538; 1539; 1540; 1541; 1542; 1543; 1544; 1545; 1546;
+    1547; 1548; 1549; 1550; 1551; 1552; 1553; 1554; 1555; 1556; 1557; 1558; 1559;
+    1560; 1561; 1562; 1563; 1564; 1565; 1566; 1567; 1568; 1569; 1570; 1571; 1572;
+    1573; 1574; 1575; 1576; 1577; 1578; 1579; 1580; 1581; 1582; 1583; 1584; 1585;
+    1586; 1587; 1588; 1589; 1590; 1591; 1592; 1593; 1594; 1595; 1596; 1597; 1598;
+    1599; 1600; 1601; 1602; 1603; 1604; 1605; 1606; 1607; 1608; 1609; 1610; 1611;
+    1612; 1613; 1614; 1615; 1616; 1617; 1618; 1619; 1620; 1621; 1622; 1623; 1624;
+    1625; 1626; 1627; 1628; 1629; 1630; 1631; 1632; 1633; 1634; 1635; 1636; 1637;
+    1638; 1639; 1640; 1641; 1642; 1643; 1644; 1645; 1646; 1647; 1648; 1649; 1650;
+    1651; 1652; 1653; 1654; 1655; 1656; 1657; 1658; 1659; 1660; 1661; 1662; 1663;
+    1664; 1665; 1666; 1667; 1668; 1669; 1670; 1671; 1672; 1673; 1674; 1675; 1676;
+    1677; 1678; 1679; 1680; 1681; 1682; 1683; 1684; 1685; 1686; 1687; 1688; 1689;
+    1690; 1691; 1692; 1693; 1694; 1695; 1696; 1697; 1698; 1699; 1700; 1701; 1702;
+    1703; 1704; 1705; 1706; 1707; 1708; 1709; 1710; 1711; 1712; 1713; 1714; 1715;
+    1716; 1717; 1718; 1719; 1720; 1721; 1722; 1723; 1724; 1725; 1726; 1727; 1728;
+    1729; 1730; 1731; 1732; 1733; 1734; 1735; 1736; 1737; 1738; 1739; 1740; 1741;
+    1742; 1743; 1744; 1745; 1746; 1747; 1748; 1749; 1750; 1751; 1752; 1753; 1754;
+    1755; 1756; 1757; 1758; 1759; 1760; 1761; 1762; 1763; 1764; 1765; 1766; 1767;
+    1768; 1769; 1770; 1771; 1772; 1773; 1774; 1775; 1776; 1777; 1778; 1779; 1780;
+    1781; 1782; 1783; 1784; 1785; 1786; 1787; 1788; 1789; 1790; 1791; 1792; 1793;
+    1794; 1795; 1796; 1797; 1798; 1799; 1800; 1801; 1802; 1803; 1804; 1805; 1806;
+    1807; 1808; 1809; 1810; 1811; 1812; 1813; 1814; 1815; 1816; 1817; 1818; 1819;
+    1820; 1821; 1822; 1823; 1824; 1825; 1826; 1827; 1828; 1829; 1830; 1831; 1832;
+    1833; 1834; 1835; 1836; 1837; 1838; 1839; 1840; 1841; 1842; 1843; 1844; 1845;
+    1846; 1847; 1848; 1849; 1850; 1851; 1852; 1853; 1854; 1855; 1856; 1857; 1858;
+    1859; 1860; 1861; 1862; 1863; 1864; 1865; 1866; 1867; 1868; 1869; 1870; 1871;
+    1872; 1873; 1874; 1875; 1876; 1877; 1878; 1879; 1880; 1881; 1882; 1883; 1884;
+    1885; 1886; 1887; 1888; 1889; 1890; 1891; 1892; 1893; 1894; 1895; 1896; 1897;
+    1898; 1899; 1900; 1901; 1902; 1903; 1904; 1905; 1906; 1907; 1908; 1909; 1910;
+    1911; 1912; 1913; 1914; 1915; 1916; 1917; 1918; 1919; 1920; 1921; 1922; 1923;
+    1924; 1925; 1926; 1927; 1928; 1929; 1930; 1931; 1932; 1933; 1934; 1935; 1936;
+    1937; 1938; 1939; 1940; 1941; 1942; 1943; 1944; 1945; 1946; 1947; 1948; 1949;
+    1950; 1951; 1952; 1953; 1954; 1955; 1956; 1957; 1958; 1959; 1960; 1961; 1962;
+    1963; 1964; 1965; 1966; 1967; 1968; 1969; 1970; 1971; 1972; 1973; 1974; 1975;
+    1976; 1977; 1978; 1979; 1980; 1981; 1982; 1983; 1984; 1985; 1986; 1987; 1988;
+    1989; 1990; 1991; 1992; 1993; 1994; 1995; 1996; 1997; 1998; 1999; 2000; 2001;
+    2002; 2003; 2004; 2005; 2006; 2007; 2008; 2009; 2010; 2011; 2012; 2013; 2014;
+    2015; 2016; 2017; 2018; 2019; 2020; 2021; 2022; 2023; 2024; 2025; 2026; 2027;
+    2028; 2029; 2030; 2031; 2032; 2033; 2034; 2035; 2036; 2037; 2038; 2039; 2040;
+    2041; 2042; 2043; 2044; 2045; 2046; 2047; 2048; 2049; 2050; 2051; 2052; 2053;
+    2054; 2055; 2056; 2057; 2058; 2059; 2060; 2061; 2062; 2063; 2064; 2065; 2066;
+    2067; 2068; 2069; 2070; 2071; 2072; 2073; 2074; 2075; 2076; 2077; 2078; 2079;
+    2080; 2081; 2082; 2083; 2084; 2085; 2086; 2087; 2088; 2089; 2090; 2091; 2092;
+    2093; 2094; |]
+
+let () =
+  let long_array = Sys.opaque_identity long_array in
+  for i = 0 to Array.length long_array - 1 do
+    assert(long_array.(i) = i)
+  done
diff --git a/testsuite/tests/basic-more/structural_constants.reference b/testsuite/tests/basic-more/structural_constants.reference
new file mode 100644
index 00000000..197c9280
--- /dev/null
+++ b/testsuite/tests/basic-more/structural_constants.reference
@@ -0,0 +1,2 @@
+
+All tests succeeded.
diff --git a/testsuite/tests/basic-more/tbuffer.ml b/testsuite/tests/basic-more/tbuffer.ml
index 75f49dd1..b8348575 100644
--- a/testsuite/tests/basic-more/tbuffer.ml
+++ b/testsuite/tests/basic-more/tbuffer.ml
@@ -1,15 +1,3 @@
-(*************************************************************************)
-(*                                                                       *)
-(*                                 OCaml                                 *)
-(*                                                                       *)
-(*            Pierre Weis, projet Estime, INRIA Rocquencourt             *)
-(*                                                                       *)
-(*   Copyright 2009 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.                *)
-(*                                                                       *)
-(*************************************************************************)
-
 (* Dummy substitute function. *)
 
 open Testing;;
diff --git a/testsuite/tests/basic-more/testrandom.ml b/testsuite/tests/basic-more/testrandom.ml
index 4588bb81..8a7ab475 100644
--- a/testsuite/tests/basic-more/testrandom.ml
+++ b/testsuite/tests/basic-more/testrandom.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1995 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Random
 
 let _ =
diff --git a/testsuite/tests/basic-more/tformat.ml b/testsuite/tests/basic-more/tformat.ml
index 64176d88..7a628ed6 100644
--- a/testsuite/tests/basic-more/tformat.ml
+++ b/testsuite/tests/basic-more/tformat.ml
@@ -1,15 +1,3 @@
-(*************************************************************************)
-(*                                                                       *)
-(*                                 OCaml                                 *)
-(*                                                                       *)
-(*            Pierre Weis, projet Estime, INRIA Rocquencourt             *)
-(*                                                                       *)
-(*   Copyright 2009 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 testbed file for the module Format.
diff --git a/testsuite/tests/basic-more/tprintf.ml b/testsuite/tests/basic-more/tprintf.ml
index 035bfe11..13b54a9e 100644
--- a/testsuite/tests/basic-more/tprintf.ml
+++ b/testsuite/tests/basic-more/tprintf.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*              Pierre Weis, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2006 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Testing;;
 
 open Printf;;
diff --git a/testsuite/tests/basic-multdef/multdef.ml b/testsuite/tests/basic-multdef/multdef.ml
index f1935d85..46869c45 100644
--- a/testsuite/tests/basic-multdef/multdef.ml
+++ b/testsuite/tests/basic-multdef/multdef.ml
@@ -1,17 +1,2 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let f x = x + 1
 external g : string -> int = "caml_int_of_string"
diff --git a/testsuite/tests/basic-multdef/multdef.mli b/testsuite/tests/basic-multdef/multdef.mli
index d6f8c090..8d67a548 100644
--- a/testsuite/tests/basic-multdef/multdef.mli
+++ b/testsuite/tests/basic-multdef/multdef.mli
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 val f : int -> int
 val f : int -> int
 val g : string -> int
diff --git a/testsuite/tests/basic-multdef/usemultdef.ml b/testsuite/tests/basic-multdef/usemultdef.ml
index 3ec7639c..2bccabb6 100644
--- a/testsuite/tests/basic-multdef/usemultdef.ml
+++ b/testsuite/tests/basic-multdef/usemultdef.ml
@@ -1,16 +1 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let _ = print_int(Multdef.f 1); print_newline(); exit 0
diff --git a/testsuite/tests/basic-private/length.ml b/testsuite/tests/basic-private/length.ml
index 5db6c45d..c36e6702 100644
--- a/testsuite/tests/basic-private/length.ml
+++ b/testsuite/tests/basic-private/length.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*              Pierre Weis, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (*
 
 A testbed file for private type abbreviation definitions.
diff --git a/testsuite/tests/basic-private/length.mli b/testsuite/tests/basic-private/length.mli
index 6478f782..67d055db 100644
--- a/testsuite/tests/basic-private/length.mli
+++ b/testsuite/tests/basic-private/length.mli
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*              Pierre Weis, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (*
 
 A testbed file for private type abbreviation definitions.
diff --git a/testsuite/tests/basic-private/tlength.ml b/testsuite/tests/basic-private/tlength.ml
index 812057bb..73f0bf95 100644
--- a/testsuite/tests/basic-private/tlength.ml
+++ b/testsuite/tests/basic-private/tlength.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*              Pierre Weis, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (*
 
 A testbed file for private type abbreviation definitions.
diff --git a/testsuite/tests/basic/Makefile b/testsuite/tests/basic/Makefile
index c11a415f..446664a9 100644
--- a/testsuite/tests/basic/Makefile
+++ b/testsuite/tests/basic/Makefile
@@ -13,6 +13,21 @@
 #*                                                                        *
 #**************************************************************************
 
+all: pr6322.ml check
+
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.several
 include $(BASEDIR)/makefiles/Makefile.common
+
+GENERATED_SOURCES=pr6322.ml *.safe-string
+
+pr6322.ml: $(SAFE_STRING).safe-string
+ifeq ($(SAFE_STRING),false)
+	@cat pr6322.ml.in > $@
+else
+	@echo "Printf.printf \"PR#6322=Ok\\n%!\"" > $@
+endif
+
+%.safe-string:
+	@rm -f pr6322.ml
+	@touch $@
diff --git a/testsuite/tests/basic/arrays.ml b/testsuite/tests/basic/arrays.ml
index a873aa58..1ec4e4eb 100644
--- a/testsuite/tests/basic/arrays.ml
+++ b/testsuite/tests/basic/arrays.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1995 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let bigarray n = [|
 n+0; n+1; n+2; n+3; n+4; n+5; n+6; n+7; n+8; n+9; n+10; n+11; n+12;
 n+13; n+14; n+15; n+16; n+17; n+18; n+19; n+20; n+21; n+22; n+23;
diff --git a/testsuite/tests/basic/bigints.ml b/testsuite/tests/basic/bigints.ml
index 3fce1a87..23e571c3 100644
--- a/testsuite/tests/basic/bigints.ml
+++ b/testsuite/tests/basic/bigints.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let _ =
   match Sys.word_size with
   | 32 ->
diff --git a/testsuite/tests/basic/boxedints.ml b/testsuite/tests/basic/boxedints.ml
index 00f936bb..016916f4 100644
--- a/testsuite/tests/basic/boxedints.ml
+++ b/testsuite/tests/basic/boxedints.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2000 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Test the types nativeint, int32, int64 *)
 
 open Printf
diff --git a/testsuite/tests/basic/constprop.ml b/testsuite/tests/basic/constprop.ml
index 62bf5f25..89d98883 100644
--- a/testsuite/tests/basic/constprop.ml
+++ b/testsuite/tests/basic/constprop.ml
@@ -1,15 +1,3 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                                OCaml                                *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Gallium, INRIA Rocquencourt         *)
-(*                                                                     *)
-(* Copyright 2014 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.                *)
-(*                                                                     *)
-(***********************************************************************)
-
 (* Test constant propagation through inlining *)
 
 (* constprop.ml is generated from constprop.mlp using
diff --git a/testsuite/tests/basic/constprop.mlp b/testsuite/tests/basic/constprop.mlp
index 3f680965..f08bc50f 100644
--- a/testsuite/tests/basic/constprop.mlp
+++ b/testsuite/tests/basic/constprop.mlp
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Test constant propagation through inlining *)
 
 (* constprop.ml is generated from constprop.mlp using
diff --git a/testsuite/tests/basic/divint.ml b/testsuite/tests/basic/divint.ml
index 8299f045..77c165ba 100644
--- a/testsuite/tests/basic/divint.ml
+++ b/testsuite/tests/basic/divint.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, 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 GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Printf
 
 (* Test integer division and modulus, esp. ocamlopt's optimization
diff --git a/testsuite/tests/basic/equality.ml b/testsuite/tests/basic/equality.ml
index 6e8d9a00..ebf5cf43 100644
--- a/testsuite/tests/basic/equality.ml
+++ b/testsuite/tests/basic/equality.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let test n check res =
   print_string "Test "; print_int n;
   if check res then print_string " passed.\n" else print_string " FAILED.\n";
diff --git a/testsuite/tests/basic/float.ml b/testsuite/tests/basic/float.ml
index 0f1a93a4..9ebabbc4 100644
--- a/testsuite/tests/basic/float.ml
+++ b/testsuite/tests/basic/float.ml
@@ -1,16 +1 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Damien Doligez, projet Moscova, INRIA Rocqencourt            *)
-(*                                                                        *)
-(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 Printf.printf "1./.0. = %f\n" (1.0 /. 0.0);;
diff --git a/testsuite/tests/basic/includestruct.ml b/testsuite/tests/basic/includestruct.ml
index bc0611c4..15708bf9 100644
--- a/testsuite/tests/basic/includestruct.ml
+++ b/testsuite/tests/basic/includestruct.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2001 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Test for "include " inside structures *)
 
 module A =
diff --git a/testsuite/tests/basic/localexn.ml b/testsuite/tests/basic/localexn.ml
new file mode 100755
index 00000000..b0f8e85f
--- /dev/null
+++ b/testsuite/tests/basic/localexn.ml
@@ -0,0 +1,9 @@
+let f (type t) () =
+  let exception E of t in
+  (fun x -> E x), (function E _ -> print_endline "OK" | _ -> print_endline "KO")
+
+let inj1, proj1 = f ()
+let inj2, proj2 = f ()
+
+let () = proj1 (inj1 42)
+let () = proj1 (inj2 42)
diff --git a/testsuite/tests/basic/localexn.reference b/testsuite/tests/basic/localexn.reference
new file mode 100644
index 00000000..cd89967b
--- /dev/null
+++ b/testsuite/tests/basic/localexn.reference
@@ -0,0 +1,2 @@
+OK
+KO
diff --git a/testsuite/tests/basic/maps.ml b/testsuite/tests/basic/maps.ml
index 24b0e337..2ed02dec 100644
--- a/testsuite/tests/basic/maps.ml
+++ b/testsuite/tests/basic/maps.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 module IntMap = Map.Make(struct type t = int let compare x y = x-y end)
 
 let m1 = IntMap.add 0 "A" (IntMap.add 4 "Y" (IntMap.singleton 3 "X1"))
diff --git a/testsuite/tests/basic/patmatch.ml b/testsuite/tests/basic/patmatch.ml
index ce57ea50..43026be2 100644
--- a/testsuite/tests/basic/patmatch.ml
+++ b/testsuite/tests/basic/patmatch.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Tests for matchings on integers and characters *)
 
 (* Dense integer switch *)
@@ -66,10 +51,12 @@ let l = function
 
 open Printf
 
-external string_create: int -> string = "caml_create_string"
+external bytes_create: int -> bytes = "caml_create_bytes"
 external unsafe_chr: int -> char = "%identity"
-external string_unsafe_set : string -> int -> char -> unit
-                           = "%string_unsafe_set"
+external bytes_unsafe_set : bytes -> int -> char -> unit
+                           = "%bytes_unsafe_set"
+
+external unsafe_to_string : bytes -> string = "%bytes_to_string"
 
 (* The following function is roughly equivalent to Char.escaped,
    except that it is locale-independent. *)
@@ -82,17 +69,17 @@ let escaped = function
   | '\b' -> "\\b"
   | c ->
     if ((k c) <> "othr") && ((Char.code c) <= 191) then begin
-      let s = string_create 1 in
-      string_unsafe_set s 0 c;
-      s
+      let s = bytes_create 1 in
+      bytes_unsafe_set s 0 c;
+      unsafe_to_string s
     end else begin
       let n = Char.code c in
-      let s = string_create 4 in
-      string_unsafe_set s 0 '\\';
-      string_unsafe_set s 1 (unsafe_chr (48 + n / 100));
-      string_unsafe_set s 2 (unsafe_chr (48 + (n / 10) mod 10));
-      string_unsafe_set s 3 (unsafe_chr (48 + n mod 10));
-      s
+      let s = bytes_create 4 in
+      bytes_unsafe_set s 0 '\\';
+      bytes_unsafe_set s 1 (unsafe_chr (48 + n / 100));
+      bytes_unsafe_set s 2 (unsafe_chr (48 + (n / 10) mod 10));
+      bytes_unsafe_set s 3 (unsafe_chr (48 + n mod 10));
+      unsafe_to_string s
     end
 
 let _ =
@@ -159,18 +146,6 @@ let () =
   let r = test Foo false in
   if r = 0 then printf "PR#5788=Ok\n"
 
-
-(* No string sharing PR#6322 *)
-let test x = match x with
-  | true -> "a"
-  | false -> "a"
-
-let () =
-  let s1 = test true in
-  let s2 = test false in
-  s1.[0] <- 'p';
-  if s1 <> s2 then printf "PR#6322=Ok\n%!"
-
 (* PR#6646 Avoid explosion of default cases when there are many constructors *)
 
 (* This took forever to compile *)
diff --git a/testsuite/tests/basic/patmatch.reference b/testsuite/tests/basic/patmatch.reference
index 868bcf53..11cd189a 100644
--- a/testsuite/tests/basic/patmatch.reference
+++ b/testsuite/tests/basic/patmatch.reference
@@ -69,7 +69,6 @@ l([|4;5;6|]) = 15
 PR#5992=Ok
 PR#5788=Ok
 PR#5788=Ok
-PR#6322=Ok
 PR#6646=Ok
 PR#6646=Ok
 PR#6676=Ok
diff --git a/testsuite/tests/basic/pr6322.ml.in b/testsuite/tests/basic/pr6322.ml.in
new file mode 100644
index 00000000..460f0a3c
--- /dev/null
+++ b/testsuite/tests/basic/pr6322.ml.in
@@ -0,0 +1,11 @@
+(* No string sharing PR#6322. This test is not applicable when OCaml is compiled with -safe-string. *)
+
+let test x = match x with
+  | true -> "a"
+  | false -> "a"
+
+let () =
+  let s1 = test true in
+  let s2 = test false in
+  s1.[0] <- 'p';
+  if s1 <> s2 then Printf.printf "PR#6322=Ok\n%!"
diff --git a/testsuite/tests/basic/pr6322.reference b/testsuite/tests/basic/pr6322.reference
new file mode 100644
index 00000000..e07c25c6
--- /dev/null
+++ b/testsuite/tests/basic/pr6322.reference
@@ -0,0 +1 @@
+PR#6322=Ok
diff --git a/testsuite/tests/basic/recvalues.ml b/testsuite/tests/basic/recvalues.ml
index 1a5a7bec..df32f5e7 100644
--- a/testsuite/tests/basic/recvalues.ml
+++ b/testsuite/tests/basic/recvalues.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Recursive value definitions *)
 
 let _ =
diff --git a/testsuite/tests/basic/sets.ml b/testsuite/tests/basic/sets.ml
index 4fad1802..8ce6ad59 100644
--- a/testsuite/tests/basic/sets.ml
+++ b/testsuite/tests/basic/sets.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 module IntSet = Set.Make(struct type t = int let compare x y = x-y end)
 
 let even = List.fold_right IntSet.add [0; -2; 2; 4; 6; -10] IntSet.empty
diff --git a/testsuite/tests/basic/stringmatch.ml b/testsuite/tests/basic/stringmatch.ml
index be913cf4..e1f4bdb4 100644
--- a/testsuite/tests/basic/stringmatch.ml
+++ b/testsuite/tests/basic/stringmatch.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Luc Maranget, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Empty string oddities *)
 
 let rec tst01 s = match s with
diff --git a/testsuite/tests/basic/tailcalls.ml b/testsuite/tests/basic/tailcalls.ml
index a86e490b..9e998139 100644
--- a/testsuite/tests/basic/tailcalls.ml
+++ b/testsuite/tests/basic/tailcalls.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2000 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let rec tailcall4 a b c d =
   if a < 0
   then b
diff --git a/testsuite/tests/callback/tcallback.ml b/testsuite/tests/callback/tcallback.ml
index 9ff755cc..121d3c57 100644
--- a/testsuite/tests/callback/tcallback.ml
+++ b/testsuite/tests/callback/tcallback.ml
@@ -1,17 +1,4 @@
 (**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1995 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
 
 external mycallback1 : ('a -> 'b) -> 'a -> 'b = "mycallback1"
 external mycallback2 : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c = "mycallback2"
diff --git a/testsuite/tests/docstrings/Makefile b/testsuite/tests/docstrings/Makefile
new file mode 100644
index 00000000..ec94f6c1
--- /dev/null
+++ b/testsuite/tests/docstrings/Makefile
@@ -0,0 +1,4 @@
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.dparsetree
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/docstrings/empty.ml b/testsuite/tests/docstrings/empty.ml
new file mode 100644
index 00000000..a4394f68
--- /dev/null
+++ b/testsuite/tests/docstrings/empty.ml
@@ -0,0 +1,8 @@
+type t = Label (**)
+(** attached to t *)
+
+(**)
+
+(** Empty docstring comments should not generate attributes *)
+
+type w (**)
diff --git a/testsuite/tests/docstrings/empty.ml.reference b/testsuite/tests/docstrings/empty.ml.reference
new file mode 100644
index 00000000..5a91a65a
--- /dev/null
+++ b/testsuite/tests/docstrings/empty.ml.reference
@@ -0,0 +1,52 @@
+[
+  structure_item (empty.ml[1,0+0]..[1,0+14])
+    Pstr_type Rec
+    [
+      type_declaration "t" (empty.ml[1,0+5]..[1,0+6]) (empty.ml[1,0+0]..[1,0+14])
+        attribute "ocaml.doc"
+          [
+            structure_item (empty.ml[2,20+0]..[2,20+20])
+              Pstr_eval
+              expression (empty.ml[2,20+0]..[2,20+20])
+                Pexp_constant PConst_string(" attached to t ",None)
+          ]
+        ptype_params =
+          []
+        ptype_cstrs =
+          []
+        ptype_kind =
+          Ptype_variant
+            [
+              (empty.ml[1,0+9]..[1,0+14])
+                "Label" (empty.ml[1,0+9]..[1,0+14])
+                []
+                None
+            ]
+        ptype_private = Public
+        ptype_manifest =
+          None
+    ]
+  structure_item (empty.ml[6,48+0]..[6,48+62])
+    Pstr_attribute "ocaml.text"
+    [
+      structure_item (empty.ml[6,48+0]..[6,48+62])
+        Pstr_eval
+        expression (empty.ml[6,48+0]..[6,48+62])
+          Pexp_constant PConst_string(" Empty docstring comments should not generate attributes ",None)
+    ]
+  structure_item (empty.ml[8,112+0]..[8,112+6])
+    Pstr_type Rec
+    [
+      type_declaration "w" (empty.ml[8,112+5]..[8,112+6]) (empty.ml[8,112+0]..[8,112+6])
+        ptype_params =
+          []
+        ptype_cstrs =
+          []
+        ptype_kind =
+          Ptype_abstract
+        ptype_private = Public
+        ptype_manifest =
+          None
+    ]
+]
+
diff --git a/testsuite/tests/embedded/cmcaml.ml b/testsuite/tests/embedded/cmcaml.ml
index fbddd2b5..ae21a1f2 100644
--- a/testsuite/tests/embedded/cmcaml.ml
+++ b/testsuite/tests/embedded/cmcaml.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* OCaml part of the code *)
 
 let rec fib n =
diff --git a/testsuite/tests/exotic-syntax/exotic.ml b/testsuite/tests/exotic-syntax/exotic.ml
index 719d4e6e..51b968aa 100644
--- a/testsuite/tests/exotic-syntax/exotic.ml
+++ b/testsuite/tests/exotic-syntax/exotic.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                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 GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Exotic OCaml syntax constructs found in the manual that are not *)
 (* used in the source of the OCaml distribution (even in the tests). *)
 
diff --git a/testsuite/tests/extension-constructor/test.ml b/testsuite/tests/extension-constructor/test.ml
index 7ffdb1c0..d73777a3 100644
--- a/testsuite/tests/extension-constructor/test.ml
+++ b/testsuite/tests/extension-constructor/test.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                  Jeremie Dimino, Jane Street Europe                    *)
-(*                                                                        *)
-(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 type t = ..
 
 module M = struct
diff --git a/testsuite/tests/float-unboxing/Makefile b/testsuite/tests/float-unboxing/Makefile
index d36ba939..8f44b4fa 100644
--- a/testsuite/tests/float-unboxing/Makefile
+++ b/testsuite/tests/float-unboxing/Makefile
@@ -11,9 +11,22 @@
 #(***********************************************************************)
 
 BASEDIR=../..
-MODULES=
+MODULES=float_inline
 MAIN_MODULE=float_subst_boxed_number
 ADD_OPTCOMPFLAGS=-inline 20
 
 include $(BASEDIR)/makefiles/Makefile.one
 include $(BASEDIR)/makefiles/Makefile.common
+
+GENERATED_SOURCES=float_inline.ml *.flambda
+
+float_inline.ml: $(FLAMBDA).flambda
+ifeq ($(FLAMBDA),false)
+	@echo "let eliminate_intermediate_float_record () = ()" > $@
+else
+	@cat float_flambda.ml > $@
+endif
+
+%.flambda:
+	@rm -f float_inline.ml
+	@touch $@
diff --git a/testsuite/tests/float-unboxing/float_flambda.ml b/testsuite/tests/float-unboxing/float_flambda.ml
new file mode 100644
index 00000000..3c5dfded
--- /dev/null
+++ b/testsuite/tests/float-unboxing/float_flambda.ml
@@ -0,0 +1,9 @@
+let eliminate_intermediate_float_record () =
+  let r = ref 0. in
+  for n = 1 to 1000 do
+    let open Complex in
+    let c = { re = float n; im = 0. } in
+    r := !r +. (norm [@inlined]) ((add [@inlined]) c i);
+  done;
+  ignore (Sys.opaque_identity !r)
+
diff --git a/testsuite/tests/float-unboxing/float_subst_boxed_number.ml b/testsuite/tests/float-unboxing/float_subst_boxed_number.ml
index 58e5c3f3..209b6a4f 100644
--- a/testsuite/tests/float-unboxing/float_subst_boxed_number.ml
+++ b/testsuite/tests/float-unboxing/float_subst_boxed_number.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                    Mark Shinwell, Jane Street Europe                   *)
-(*                                                                        *)
-(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 module PR_6686 = struct
   type t =
    | A of float
@@ -52,7 +37,8 @@ let check_noalloc name f =
   match Filename.basename Sys.argv.(0) with
   | "program.byte" | "program.byte.exe" -> ()
   | "program.native" | "program.native.exe" ->
-    if alloc > 100. then failwith name
+      if alloc > 100. then
+        failwith (Printf.sprintf "%s; alloc = %.0f" name alloc)
   | _ -> assert false
 
 module GPR_109 = struct
@@ -75,7 +61,8 @@ let unbox_classify_float () =
   for i = 1 to 1000 do
     assert (classify_float !x = FP_normal);
     x := !x +. 1.
-  done
+  done;
+  ignore (Sys.opaque_identity !x)
 
 let unbox_compare_float () =
   let module M = struct type sf = { mutable x: float; y: float; } end in
@@ -83,9 +70,95 @@ let unbox_compare_float () =
   for i = 1 to 1000 do
     assert (compare x.M.x x.M.y >= 0);
     x.M.x <- x.M.x +. 1.
+  done;
+  ignore (Sys.opaque_identity x.M.x)
+
+let unbox_float_refs () =
+  let r = ref nan in
+  for i = 1 to 1000 do r := !r +. float i done;
+  ignore (Sys.opaque_identity !r)
+
+let unbox_let_float () =
+  let r = ref 0. in
+  for i = 1 to 1000 do
+    let y =
+      if i mod 2 = 0 then nan else float i
+    in
+    r := !r +. (y *. 2.)
+  done;
+  ignore (Sys.opaque_identity !r)
+
+type block =
+  { mutable float : float;
+    mutable int32 : int32 }
+
+let make_some_block record =
+  { record with int32 = record.int32 }
+
+let unbox_record_1 record =
+  (* There is some let lifting problem to handle that case with one
+     round, this currently requires 2 rounds to be correctly
+     recognized as a mutable variable pattern *)
+  (* let block = (make_some_block [@inlined]) record in *)
+  let block = { record with int32 = record.int32 } in
+  for i = 1 to 1000 do
+    let y_float =
+      if i mod 2 = 0 then nan else Pervasives.float i
+    in
+    block.float <- block.float +. (y_float *. 2.);
+    let y_int32 =
+      if i mod 2 = 0 then Int32.max_int else Int32.of_int i
+    in
+    block.int32 <- Int32.(add block.int32 (mul y_int32 2l))
+  done;
+  ignore (Sys.opaque_identity block.float);
+  ignore (Sys.opaque_identity block.int32)
+  [@@inline never]
+  (* Prevent inlining to test that the type is effectively used *)
+
+let float_int32_record = { float = 3.14; int32 = 12l }
+
+let unbox_record () =
+  unbox_record_1 float_int32_record
+
+let r = ref 0.
+
+let unbox_only_if_useful () =
+  for i = 1 to 1000 do
+    let x =
+      if i mod 2 = 0 then 1.
+      else 0.
+    in
+    r := x; (* would force boxing if the let binding above were unboxed *)
+    r := x  (* use [x] twice to avoid elimination of the let-binding *)
+  done;
+  ignore (Sys.opaque_identity !r)
+
+let unbox_minor_words () =
+  for i = 1 to 1000 do
+    ignore (Gc.minor_words () = 0.)
   done
 
 let () =
+  let flambda =
+    match Sys.getenv "FLAMBDA" with
+    | "true" -> true
+    | "false" -> false
+    | _ -> failwith "Cannot determine is flambda is enabled"
+    | exception Not_found -> failwith "Cannot determine is flambda is enabled"
+  in
+
   check_noalloc "classify float" unbox_classify_float;
   check_noalloc "compare float" unbox_compare_float;
+  check_noalloc "float refs" unbox_float_refs;
+  check_noalloc "unbox let float" unbox_let_float;
+  check_noalloc "unbox only if useful" unbox_only_if_useful;
+
+  if flambda then begin
+    check_noalloc "float and int32 record" unbox_record;
+    check_noalloc "eliminate intermediate immutable float record"
+      Float_inline.eliminate_intermediate_float_record;
+  end;
+
+  check_noalloc "Gc.minor_words" unbox_minor_words;
   ()
diff --git a/testsuite/tests/gc-roots/globroots.ml b/testsuite/tests/gc-roots/globroots.ml
index a12e2456..016277cf 100644
--- a/testsuite/tests/gc-roots/globroots.ml
+++ b/testsuite/tests/gc-roots/globroots.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2001 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 module type GLOBREF = sig
   type t
   val register: string -> t
@@ -84,6 +69,9 @@ end
 module TestClassic = Test(Classic)
 module TestGenerational = Test(Generational)
 
+external young2old : unit -> unit = "gb_young2old"
+let _ = young2old (); Gc.full_major ()
+
 let _ =
   let n =
     if Array.length Sys.argv < 2 then 10000 else int_of_string Sys.argv.(1) in
diff --git a/testsuite/tests/gc-roots/globrootsprim.c b/testsuite/tests/gc-roots/globrootsprim.c
index 5c540acf..28ad2267 100644
--- a/testsuite/tests/gc-roots/globrootsprim.c
+++ b/testsuite/tests/gc-roots/globrootsprim.c
@@ -69,3 +69,15 @@ value gb_generational_remove(value vblock)
   caml_remove_generational_global_root(&(Block_val(vblock)->v));
   return Val_unit;
 }
+
+value root;
+
+value gb_young2old(value _dummy) {
+  root = caml_alloc_small(1, 0);
+  caml_register_generational_global_root(&root);
+  caml_modify_generational_global_root(&root, caml_alloc_shr(10, String_tag));
+  Field(root, 0) = 0xFFFFFFFF;
+  caml_remove_generational_global_root(&root);
+  root += sizeof(value);
+  return Val_unit;
+}
diff --git a/testsuite/tests/int64-unboxing/test.ml b/testsuite/tests/int64-unboxing/test.ml
index 40bed302..4bffcc67 100644
--- a/testsuite/tests/int64-unboxing/test.ml
+++ b/testsuite/tests/int64-unboxing/test.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                  Jeremie Dimino, Jane Street Europe                    *)
-(*                                                                        *)
-(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 external ( + ) : int64 -> int64 -> int64
   = "" "test_int64_add" [@@noalloc] [@@unboxed]
 external ( - ) : int64 -> int64 -> int64
diff --git a/testsuite/tests/lazy/Makefile b/testsuite/tests/lazy/Makefile
new file mode 100644
index 00000000..59613588
--- /dev/null
+++ b/testsuite/tests/lazy/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                  Mark Shinwell, Jane Street Europe                     *
+#*                                                                        *
+#*   Copyright 2016 Jane Street Group, LLC                                *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed 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=../..
+ADD_OPTFLAGS=-O3
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lazy/lazy1.ml b/testsuite/tests/lazy/lazy1.ml
new file mode 100644
index 00000000..8ec74b6e
--- /dev/null
+++ b/testsuite/tests/lazy/lazy1.ml
@@ -0,0 +1,14 @@
+(* Mantis 7301, due to A. Frisch *)
+
+let foo () =
+  (fun xs0 () -> Lazy.force (List.hd xs0) ())
+    (List.map (fun g -> lazy g)
+       [Lazy.force (  lazy ( let _ = () in fun () -> ()  ) )]
+    )
+
+let () =
+  let gen = foo () in
+  gen ();
+  Gc.compact ();
+  print_char 'A'; flush stdout;
+  gen ()
diff --git a/testsuite/tests/lazy/lazy1.reference b/testsuite/tests/lazy/lazy1.reference
new file mode 100644
index 00000000..8c7e5a66
--- /dev/null
+++ b/testsuite/tests/lazy/lazy1.reference
@@ -0,0 +1 @@
+A
\ No newline at end of file
diff --git a/testsuite/tests/letrec/backreferences.ml b/testsuite/tests/letrec/backreferences.ml
index 289f7bdb..4a893225 100644
--- a/testsuite/tests/letrec/backreferences.ml
+++ b/testsuite/tests/letrec/backreferences.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Gabriel Scherer, projet Gallium, INRIA Rocquencourt          *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* testing backreferences; some compilation scheme may handle
    differently recursive references to a mutually-recursive RHS
    depending on whether it is before or after in the bindings list *)
diff --git a/testsuite/tests/letrec/class_1.ml b/testsuite/tests/letrec/class_1.ml
index aed8fffe..a7d03388 100644
--- a/testsuite/tests/letrec/class_1.ml
+++ b/testsuite/tests/letrec/class_1.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Gabriel Scherer, projet Gallium, INRIA Rocquencourt          *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* class expression are compiled to recursive bindings *)
 class test =
 object
diff --git a/testsuite/tests/letrec/class_2.ml b/testsuite/tests/letrec/class_2.ml
index 39d69882..71c7880d 100644
--- a/testsuite/tests/letrec/class_2.ml
+++ b/testsuite/tests/letrec/class_2.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Gabriel Scherer, projet Gallium, INRIA Rocquencourt          *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* class expressions may also contain local recursive bindings *)
 class test =
   let rec f = print_endline "f"; fun x -> g x
diff --git a/testsuite/tests/letrec/evaluation_order_1.ml b/testsuite/tests/letrec/evaluation_order_1.ml
index 87d5accb..6c94439e 100644
--- a/testsuite/tests/letrec/evaluation_order_1.ml
+++ b/testsuite/tests/letrec/evaluation_order_1.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Gabriel Scherer, projet Gallium, INRIA Rocquencourt          *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* test evaluation order
 
    'y' is translated into a constant, and is therefore considered
@@ -22,9 +7,9 @@
 type tree = Tree of tree list
 
 let test =
-  let rec x = (print_endline "x"; Tree [y; z])
-  and y = (print_endline "y"; Tree [])
-  and z = (print_endline "z"; Tree [x])
+  let rec x = (print_endline "effect"; Tree [y; z])
+  and y = (print_endline "effect"; Tree [])
+  and z = (print_endline "effect"; Tree [x])
   in
   match (x, y, z) with
     | (Tree [y1; z1], Tree[], Tree[x1]) ->
diff --git a/testsuite/tests/letrec/evaluation_order_1.reference b/testsuite/tests/letrec/evaluation_order_1.reference
index f471662b..bf36c925 100644
--- a/testsuite/tests/letrec/evaluation_order_1.reference
+++ b/testsuite/tests/letrec/evaluation_order_1.reference
@@ -1,3 +1,3 @@
-y
-x
-z
+effect
+effect
+effect
diff --git a/testsuite/tests/letrec/evaluation_order_2.ml b/testsuite/tests/letrec/evaluation_order_2.ml
index 25b2c81c..f8a845bd 100644
--- a/testsuite/tests/letrec/evaluation_order_2.ml
+++ b/testsuite/tests/letrec/evaluation_order_2.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Gabriel Scherer, projet Gallium, INRIA Rocquencourt          *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* A variant of evaluation_order_1.ml where the side-effects
    are inside the blocks.
    Effect are not named to allow different evaluation orders (flambda
diff --git a/testsuite/tests/letrec/evaluation_order_3.ml b/testsuite/tests/letrec/evaluation_order_3.ml
index 64144a3f..8f76a8f8 100644
--- a/testsuite/tests/letrec/evaluation_order_3.ml
+++ b/testsuite/tests/letrec/evaluation_order_3.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Gabriel Scherer, projet Gallium, INRIA Rocquencourt          *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 type t = { x : t; y : t }
 
 let p = print_endline
diff --git a/testsuite/tests/letrec/float_block_1.ml b/testsuite/tests/letrec/float_block_1.ml
index 21189e8f..b2f878bb 100644
--- a/testsuite/tests/letrec/float_block_1.ml
+++ b/testsuite/tests/letrec/float_block_1.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Gabriel Scherer, projet Gallium, INRIA Rocquencourt          *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Effect are not named to allow different evaluation orders (flambda
    and clambda differ on this point).
  *)
diff --git a/testsuite/tests/letrec/float_block_2.ml b/testsuite/tests/letrec/float_block_2.ml
index e28011e1..968cba4e 100644
--- a/testsuite/tests/letrec/float_block_2.ml
+++ b/testsuite/tests/letrec/float_block_2.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Gabriel Scherer, projet Gallium, INRIA Rocquencourt          *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* a bug in cmmgen.ml provokes a segfault in certain natively compiled
    letrec-bindings involving float arrays *)
 let test =
diff --git a/testsuite/tests/letrec/lists.ml b/testsuite/tests/letrec/lists.ml
index e204e449..5686e493 100644
--- a/testsuite/tests/letrec/lists.ml
+++ b/testsuite/tests/letrec/lists.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Gabriel Scherer, projet Gallium, INRIA Rocquencourt          *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* a test with lists, because cyclic lists are fun *)
 let test =
   let rec li = 0::1::2::3::4::5::6::7::8::9::li in
diff --git a/testsuite/tests/letrec/mixing_value_closures_1.ml b/testsuite/tests/letrec/mixing_value_closures_1.ml
index 8f5b112d..e79f79ec 100644
--- a/testsuite/tests/letrec/mixing_value_closures_1.ml
+++ b/testsuite/tests/letrec/mixing_value_closures_1.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Gabriel Scherer, projet Gallium, INRIA Rocquencourt          *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* mixing values and closures may exercise interesting code paths *)
 type t = A of (int -> int)
 let test =
diff --git a/testsuite/tests/letrec/mixing_value_closures_2.ml b/testsuite/tests/letrec/mixing_value_closures_2.ml
index c8ab4fe0..eb5fcb74 100644
--- a/testsuite/tests/letrec/mixing_value_closures_2.ml
+++ b/testsuite/tests/letrec/mixing_value_closures_2.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Gabriel Scherer, projet Gallium, INRIA Rocquencourt          *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* a polymorphic variant of test3.ml; found a real bug once *)
 let test =
   let rec x = `A f
diff --git a/testsuite/tests/letrec/mutual_functions.ml b/testsuite/tests/letrec/mutual_functions.ml
index 22f749f9..a5b6c51f 100644
--- a/testsuite/tests/letrec/mutual_functions.ml
+++ b/testsuite/tests/letrec/mutual_functions.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Gabriel Scherer, projet Gallium, INRIA Rocquencourt          *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* a simple test with mutually recursive functions *)
 let test =
   let rec even = function
diff --git a/testsuite/tests/letrec/record_with.ml b/testsuite/tests/letrec/record_with.ml
index 7be7f5b8..8d2d01c0 100644
--- a/testsuite/tests/letrec/record_with.ml
+++ b/testsuite/tests/letrec/record_with.ml
@@ -1,19 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Damien Doligez, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-
 (* A regression test for both PR#4141 and PR#5819: when a recursive
    variable is defined by a { record with ... } expression.
 *)
diff --git a/testsuite/tests/lib-bigarray-2/bigarrfml.ml b/testsuite/tests/lib-bigarray-2/bigarrfml.ml
index 942e2044..d33862ed 100644
--- a/testsuite/tests/lib-bigarray-2/bigarrfml.ml
+++ b/testsuite/tests/lib-bigarray-2/bigarrfml.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2000 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Bigarray
 open Printf
 
diff --git a/testsuite/tests/lib-bigarray/bigarrays.ml b/testsuite/tests/lib-bigarray/bigarrays.ml
index bdf3808e..9f8afc41 100644
--- a/testsuite/tests/lib-bigarray/bigarrays.ml
+++ b/testsuite/tests/lib-bigarray/bigarrays.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Bigarray
 open Printf
 open Complex
@@ -42,7 +27,11 @@ let test test_number answer correct_answer =
 
 (* One-dimensional arrays *)
 
-let _ =
+(* flambda can cause some of these values not to be reclaimed by the Gc, which
+ * can undermine the use of Gc.full_major for the Windows ports. All the tests
+ * are wrapped in a non-inlineable function to prevent this behaviour.
+ *)
+let tests () =
   testing_function "------ Array1 --------";
   testing_function "create/set/get";
   let test_setget kind vals =
@@ -921,10 +910,12 @@ let _ =
   Sys.remove mapped_file;
 
   ()
+  [@@inline never]
 
 (********* End of test *********)
 
 let _ =
+  tests ();
   print_newline();
   if !error_occurred then begin
     prerr_endline "************* TEST FAILED ****************"; exit 2
diff --git a/testsuite/tests/lib-bigarray/fftba.ml b/testsuite/tests/lib-bigarray/fftba.ml
index 685d281d..8a01389c 100644
--- a/testsuite/tests/lib-bigarray/fftba.ml
+++ b/testsuite/tests/lib-bigarray/fftba.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Bigarray
 
 let pi = 3.14159265358979323846
diff --git a/testsuite/tests/lib-bigarray/pr5115.ml b/testsuite/tests/lib-bigarray/pr5115.ml
index 2828d084..e75215cf 100644
--- a/testsuite/tests/lib-bigarray/pr5115.ml
+++ b/testsuite/tests/lib-bigarray/pr5115.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2010 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* PR#5115 - multiple evaluation of bigarray expr *)
 
 open Bigarray
diff --git a/testsuite/tests/lib-digest/md5.ml b/testsuite/tests/lib-digest/md5.ml
index 6174ede2..1b61d152 100644
--- a/testsuite/tests/lib-digest/md5.ml
+++ b/testsuite/tests/lib-digest/md5.ml
@@ -1,24 +1,9 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2003 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Test int32 arithmetic and optimizations using the MD5 algorithm *)
 
 open Printf
 
 type context =
-  { buf: string;
+  { buf: bytes;
     mutable pos: int;
     mutable a: int32;
     mutable b: int32;
@@ -135,10 +120,10 @@ let string_to_data s =
   for i = 0 to 15 do
     let j = i lsl 2 in
     data.(i) <-
-      Int32.logor (Int32.shift_left (Int32.of_int (Char.code s.[j+3])) 24)
-        (Int32.logor (Int32.shift_left (Int32.of_int (Char.code s.[j+2])) 16)
-          (Int32.logor (Int32.shift_left (Int32.of_int (Char.code s.[j+1])) 8)
-                       (Int32.of_int (Char.code s.[j]))))
+      Int32.logor (Int32.shift_left (Int32.of_int (Bytes.get s (j+3) |> Char.code)) 24)
+        (Int32.logor (Int32.shift_left (Int32.of_int (Bytes.get s (j+2) |> Char.code)) 16)
+          (Int32.logor (Int32.shift_left (Int32.of_int (Bytes.get s (j+1) |> Char.code)) 8)
+                       (Int32.of_int (Bytes.get s j |> Char.code))))
   done;
   data
 
@@ -149,7 +134,7 @@ let int32_to_string n s i =
   s.[i] <- Char.chr (Int32.to_int n land 0xFF)
 
 let init () =
-  { buf = String.create 64;
+  { buf = Bytes.create 64;
     pos = 0;
     a = 0x67452301l;
     b = 0xefcdab89l;
@@ -162,12 +147,12 @@ let update ctx input ofs len =
     if len <= 0 then () else
     if ctx.pos + len < 64 then begin
       (* Just buffer the data *)
-      String.blit input ofs ctx.buf ctx.pos len;
+      Bytes.blit_string input ofs ctx.buf ctx.pos len;
       ctx.pos <- ctx.pos + len
     end else begin
       (* Fill the buffer *)
       let len' = 64 - ctx.pos in
-      if len' > 0 then String.blit input ofs ctx.buf ctx.pos len';
+      if len' > 0 then Bytes.blit_string input ofs ctx.buf ctx.pos len';
       (* Transform 64 bytes *)
       transform ctx (string_to_data ctx.buf);
       ctx.pos <- 0;
@@ -178,8 +163,7 @@ let update ctx input ofs len =
 
 
 let finish ctx =
-  let padding = String.make 64 '\000' in
-  padding.[0] <- '\x80';
+  let padding = String.init 64 (function 0 -> '\x80' | _ -> '\000') in
   let numbits = ctx.bits in
   if ctx.pos < 56 then begin
     update ctx padding 0 (56 - ctx.pos)
@@ -191,12 +175,12 @@ let finish ctx =
   data.(14) <- (Int64.to_int32 numbits);
   data.(15) <- (Int64.to_int32 (Int64.shift_right_logical numbits 32));
   transform ctx data;
-  let res = String.create 16 in
+  let res = Bytes.create 16 in
   int32_to_string ctx.a res 0;
   int32_to_string ctx.b res 4;
   int32_to_string ctx.c res 8;
   int32_to_string ctx.d res 12;
-  res
+  Bytes.unsafe_to_string res
 
 let test hex s =
   let ctx = init() in
diff --git a/testsuite/tests/lib-dynlink-bytecode/main.ml b/testsuite/tests/lib-dynlink-bytecode/main.ml
index ec35b2cc..725ee80c 100644
--- a/testsuite/tests/lib-dynlink-bytecode/main.ml
+++ b/testsuite/tests/lib-dynlink-bytecode/main.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let f x = print_string "This is Main.f\n"; x
 
 let () = Registry.register f
diff --git a/testsuite/tests/lib-dynlink-bytecode/plug1.ml b/testsuite/tests/lib-dynlink-bytecode/plug1.ml
index be6d43e1..d0490689 100644
--- a/testsuite/tests/lib-dynlink-bytecode/plug1.ml
+++ b/testsuite/tests/lib-dynlink-bytecode/plug1.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 external stub1: unit -> string = "stub1"
 
 let f x = print_string "This is Plug1.f\n"; x + 1
diff --git a/testsuite/tests/lib-dynlink-bytecode/plug2.ml b/testsuite/tests/lib-dynlink-bytecode/plug2.ml
index b8816e94..350374e5 100644
--- a/testsuite/tests/lib-dynlink-bytecode/plug2.ml
+++ b/testsuite/tests/lib-dynlink-bytecode/plug2.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 external stub2: unit -> unit = "stub2"
 
 let f x = print_string "This is Plug2.f\n"; x + 2
diff --git a/testsuite/tests/lib-dynlink-bytecode/registry.ml b/testsuite/tests/lib-dynlink-bytecode/registry.ml
index 5006bc31..e0f76423 100644
--- a/testsuite/tests/lib-dynlink-bytecode/registry.ml
+++ b/testsuite/tests/lib-dynlink-bytecode/registry.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let functions = ref ([]: (int -> int) list)
 
 let register f =
diff --git a/testsuite/tests/lib-dynlink-csharp/Makefile b/testsuite/tests/lib-dynlink-csharp/Makefile
index 8bd618e6..e3acc6b7 100644
--- a/testsuite/tests/lib-dynlink-csharp/Makefile
+++ b/testsuite/tests/lib-dynlink-csharp/Makefile
@@ -14,7 +14,8 @@
 #**************************************************************************
 
 BASEDIR=../..
-CSC=csc
+CSC_COMMAND=csc
+CSC=$(CSC_COMMAND) $(CSC_FLAGS)
 
 COMPFLAGS=-I $(OTOPDIR)/otherlibs/bigarray -I $(OTOPDIR)/otherlibs/dynlink \
           -I $(OTOPDIR)/byterun
@@ -36,10 +37,11 @@ prepare:
 .PHONY: bytecode
 bytecode:
 	@printf " ... testing 'bytecode':"
-	@if ! $(SUPPORTS_SHARED_LIBRARIES) || ! which $(CSC) >/dev/null 2>&1; \
+	@if ! $(SUPPORTS_SHARED_LIBRARIES) || ! which $(CSC_COMMAND) >/dev/null 2>&1; \
 	then \
 	  echo " => skipped"; \
 	else \
+	  rm -f main.exe main.dll; \
 	  $(OCAMLC) -output-obj -o main.dll dynlink.cma main.ml entry.c; \
 	  $(CSC) /nologo /nowarn:1668 /out:main.exe main.cs; \
 	  ./main.exe > bytecode.result; \
@@ -50,10 +52,11 @@ bytecode:
 .PHONY: bytecode-dll
 bytecode-dll:
 	@printf " ... testing 'bytecode-dll':"
-	@if ! $(SUPPORTS_SHARED_LIBRARIES) || ! which $(CSC) > /dev/null 2>&1; \
+	@if ! $(SUPPORTS_SHARED_LIBRARIES) || ! which $(CSC_COMMAND) > /dev/null 2>&1; \
 	then \
 	  echo " => skipped"; \
 	else \
+	  rm -f main.exe main_obj.$(O) main.dll; \
 	  $(OCAMLC) -output-obj -o main_obj.$(O) dynlink.cma entry.c main.ml; \
 	  $(MKDLL) -maindll -o main.dll main_obj.$(O) entry.$(O) \
 	           $(CTOPDIR)/byterun/libcamlrun.$(A)  $(BYTECCLIBS); \
@@ -67,9 +70,10 @@ bytecode-dll:
 native:
 	@printf " ... testing 'native':"
 	@if ! $(SUPPORTS_SHARED_LIBRARIES) || $(BYTECODE_ONLY) \
-	    || ! which $(CSC) > /dev/null 2>&1; then \
+	    || ! which $(CSC_COMMAND) > /dev/null 2>&1; then \
 	  echo " => skipped"; \
 	else \
+	  rm -f main.exe main.dll; \
 	  $(OCAMLOPT) -output-obj -o main.dll dynlink.cmxa entry.c main.ml; \
 	  $(CSC) /nologo /nowarn:1668 /out:main.exe main.cs; \
 	  ./main.exe > native.result; \
@@ -81,13 +85,14 @@ native:
 native-dll:
 	@printf " ... testing 'native-dll':"
 	@if ! $(SUPPORTS_SHARED_LIBRARIES) || $(BYTECODE_ONLY) \
-	    || ! which $(CSC) > /dev/null 2>&1; then \
+	    || ! which $(CSC_COMMAND) > /dev/null 2>&1; then \
 	  echo " => skipped"; \
 	else \
+	  rm -f main.exe main_obj.$(O) main.dll; \
 	  $(OCAMLOPT) -output-obj -o main_obj.$(O) dynlink.cmxa entry.c \
 	              main.ml; \
 	  $(MKDLL) -maindll -o main.dll main_obj.$(O) entry.$(O) \
-	           $(CTOPDIR)/asmrun/libasmrun.lib -v; \
+		         $(CTOPDIR)/asmrun/libasmrun.lib $(NATIVECCLIBS); \
 	  $(CSC) /nologo /nowarn:1668 /out:main.exe main.cs; \
 	  ./main.exe > native-dll.result; \
 	  $(DIFF) native.reference native-dll.result >/dev/null \
@@ -102,3 +107,13 @@ clean: defaultclean
 	@rm -f *.result *.exe *.dll *.so *.obj *.o
 
 include $(BASEDIR)/makefiles/Makefile.common
+
+ifneq ($(FLEXLINK_PREFIX),)
+MKDLL=$(WINTOPDIR)/boot/ocamlrun $(WINTOPDIR)/flexdll/flexlink.exe $(FLEXLINK_FLAGS)
+endif
+
+ifeq ($(HOST),msvc)
+CSC_FLAGS=/platform:x86
+else
+CSC_FLAGS=
+endif
diff --git a/testsuite/tests/lib-dynlink-csharp/main.ml b/testsuite/tests/lib-dynlink-csharp/main.ml
index e954e137..d30c150e 100755
--- a/testsuite/tests/lib-dynlink-csharp/main.ml
+++ b/testsuite/tests/lib-dynlink-csharp/main.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let load s =
   Printf.printf "Loading %s\n%!" s;
   try
diff --git a/testsuite/tests/lib-dynlink-csharp/plugin.ml b/testsuite/tests/lib-dynlink-csharp/plugin.ml
index ede32744..aacf9f21 100755
--- a/testsuite/tests/lib-dynlink-csharp/plugin.ml
+++ b/testsuite/tests/lib-dynlink-csharp/plugin.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let f x = x.{2}
 
 let () =
diff --git a/testsuite/tests/lib-dynlink-native/a.ml b/testsuite/tests/lib-dynlink-native/a.ml
index 7b8ac49a..b7915822 100755
--- a/testsuite/tests/lib-dynlink-native/a.ml
+++ b/testsuite/tests/lib-dynlink-native/a.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let x = ref 0
 let u = Random.int 1000
 
diff --git a/testsuite/tests/lib-dynlink-native/api.ml b/testsuite/tests/lib-dynlink-native/api.ml
index 4daa7d44..cd735abe 100644
--- a/testsuite/tests/lib-dynlink-native/api.ml
+++ b/testsuite/tests/lib-dynlink-native/api.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let mods = ref []
 
 let reg_mod name =
diff --git a/testsuite/tests/lib-dynlink-native/b.ml b/testsuite/tests/lib-dynlink-native/b.ml
index 95c142ba..afa1bef0 100755
--- a/testsuite/tests/lib-dynlink-native/b.ml
+++ b/testsuite/tests/lib-dynlink-native/b.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let () =
   print_endline "B is running";
   incr A.x;
diff --git a/testsuite/tests/lib-dynlink-native/bug.ml b/testsuite/tests/lib-dynlink-native/bug.ml
index 7c3387f9..31c0f025 100644
--- a/testsuite/tests/lib-dynlink-native/bug.ml
+++ b/testsuite/tests/lib-dynlink-native/bug.ml
@@ -1,17 +1,2 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let () = try raise (Invalid_argument "X") with Invalid_argument s ->
   raise (Invalid_argument (s ^ s))
diff --git a/testsuite/tests/lib-dynlink-native/c.ml b/testsuite/tests/lib-dynlink-native/c.ml
index c7e799a3..d4de70f4 100755
--- a/testsuite/tests/lib-dynlink-native/c.ml
+++ b/testsuite/tests/lib-dynlink-native/c.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let () =
   print_endline "C is running";
   incr A.x;
diff --git a/testsuite/tests/lib-dynlink-native/main.ml b/testsuite/tests/lib-dynlink-native/main.ml
index 20c0b9bf..8c738aeb 100644
--- a/testsuite/tests/lib-dynlink-native/main.ml
+++ b/testsuite/tests/lib-dynlink-native/main.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let () =
   Api.add_cb (fun () -> print_endline "Callback from main")
 
diff --git a/testsuite/tests/lib-dynlink-native/pack_client.ml b/testsuite/tests/lib-dynlink-native/pack_client.ml
index 0766566f..90229885 100644
--- a/testsuite/tests/lib-dynlink-native/pack_client.ml
+++ b/testsuite/tests/lib-dynlink-native/pack_client.ml
@@ -1,17 +1,2 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let () =
   print_endline Mypack.Packed1.mykey
diff --git a/testsuite/tests/lib-dynlink-native/packed1.ml b/testsuite/tests/lib-dynlink-native/packed1.ml
index 8d13cbce..2ee83633 100644
--- a/testsuite/tests/lib-dynlink-native/packed1.ml
+++ b/testsuite/tests/lib-dynlink-native/packed1.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let () =
   Api.reg_mod "Packed1"
 
diff --git a/testsuite/tests/lib-dynlink-native/packed1_client.ml b/testsuite/tests/lib-dynlink-native/packed1_client.ml
index 79416076..c62534fd 100644
--- a/testsuite/tests/lib-dynlink-native/packed1_client.ml
+++ b/testsuite/tests/lib-dynlink-native/packed1_client.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let () =
   Api.reg_mod "Packed1_client";
   print_endline Packed1.mykey
diff --git a/testsuite/tests/lib-dynlink-native/plugin.ml b/testsuite/tests/lib-dynlink-native/plugin.ml
index 14806348..d9b0574f 100644
--- a/testsuite/tests/lib-dynlink-native/plugin.ml
+++ b/testsuite/tests/lib-dynlink-native/plugin.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let rec f x = ignore ([x]); f x
 
 let rec fact n = if n = 0 then 1 else n * fact (n - 1)
diff --git a/testsuite/tests/lib-dynlink-native/plugin.mli b/testsuite/tests/lib-dynlink-native/plugin.mli
index 8e39ea09..3e659d97 100644
--- a/testsuite/tests/lib-dynlink-native/plugin.mli
+++ b/testsuite/tests/lib-dynlink-native/plugin.mli
@@ -1,16 +1 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 val facts: int list
diff --git a/testsuite/tests/lib-dynlink-native/plugin2.ml b/testsuite/tests/lib-dynlink-native/plugin2.ml
index f208d4e8..109c129d 100644
--- a/testsuite/tests/lib-dynlink-native/plugin2.ml
+++ b/testsuite/tests/lib-dynlink-native/plugin2.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (*external ex: int -> int = "caml_ex"*)
 
 let () =
diff --git a/testsuite/tests/lib-dynlink-native/plugin4.ml b/testsuite/tests/lib-dynlink-native/plugin4.ml
index c64c4a5e..a9f86e60 100644
--- a/testsuite/tests/lib-dynlink-native/plugin4.ml
+++ b/testsuite/tests/lib-dynlink-native/plugin4.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let () =
   Printf.printf "time = %f\n" (Unix.time ());
   Api.reg_mod "Plugin"
diff --git a/testsuite/tests/lib-dynlink-native/plugin_ext.ml b/testsuite/tests/lib-dynlink-native/plugin_ext.ml
index ffefb719..9906769f 100644
--- a/testsuite/tests/lib-dynlink-native/plugin_ext.ml
+++ b/testsuite/tests/lib-dynlink-native/plugin_ext.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 external fact: int -> string = "factorial"
 
 let () =
diff --git a/testsuite/tests/lib-dynlink-native/plugin_high_arity.ml b/testsuite/tests/lib-dynlink-native/plugin_high_arity.ml
index 11dc5733..8c58aa15 100644
--- a/testsuite/tests/lib-dynlink-native/plugin_high_arity.ml
+++ b/testsuite/tests/lib-dynlink-native/plugin_high_arity.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let f x x x x x x x x x x x x x = ()
 
 let g x = f x x x x x x x x
diff --git a/testsuite/tests/lib-dynlink-native/plugin_ref.ml b/testsuite/tests/lib-dynlink-native/plugin_ref.ml
index f025f615..60f12735 100644
--- a/testsuite/tests/lib-dynlink-native/plugin_ref.ml
+++ b/testsuite/tests/lib-dynlink-native/plugin_ref.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let x = ref 0
 
 let () =
diff --git a/testsuite/tests/lib-dynlink-native/plugin_simple.ml b/testsuite/tests/lib-dynlink-native/plugin_simple.ml
index 1a609cc2..dd7d0226 100644
--- a/testsuite/tests/lib-dynlink-native/plugin_simple.ml
+++ b/testsuite/tests/lib-dynlink-native/plugin_simple.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let facts = [ (Random.int 4) ]
 
 let () = print_endline "COUCOU"; print_char '\n'
diff --git a/testsuite/tests/lib-dynlink-native/plugin_thread.ml b/testsuite/tests/lib-dynlink-native/plugin_thread.ml
index 31481905..6e3d9d48 100644
--- a/testsuite/tests/lib-dynlink-native/plugin_thread.ml
+++ b/testsuite/tests/lib-dynlink-native/plugin_thread.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let () =
   Api.reg_mod "Plugin_thread";
   let _t =
diff --git a/testsuite/tests/lib-dynlink-native/sub/api.ml b/testsuite/tests/lib-dynlink-native/sub/api.ml
index bb7b2eeb..4a60586f 100644
--- a/testsuite/tests/lib-dynlink-native/sub/api.ml
+++ b/testsuite/tests/lib-dynlink-native/sub/api.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let f i =
   Printf.printf "Sub/api: f called with %i\n" i;
   i + 1
diff --git a/testsuite/tests/lib-dynlink-native/sub/api.mli b/testsuite/tests/lib-dynlink-native/sub/api.mli
index b374c00c..da5e52f2 100644
--- a/testsuite/tests/lib-dynlink-native/sub/api.mli
+++ b/testsuite/tests/lib-dynlink-native/sub/api.mli
@@ -1,16 +1 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 val f : int -> int
diff --git a/testsuite/tests/lib-dynlink-native/sub/plugin.ml b/testsuite/tests/lib-dynlink-native/sub/plugin.ml
index 5f183eb6..d7faf9c8 100644
--- a/testsuite/tests/lib-dynlink-native/sub/plugin.ml
+++ b/testsuite/tests/lib-dynlink-native/sub/plugin.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let rec fact n = if n = 0 then 1 else n * fact (n - 1)
 
 let facts = [ fact 1; fact 2; fact 3; fact 4; fact 5 ]
diff --git a/testsuite/tests/lib-dynlink-native/sub/plugin3.ml b/testsuite/tests/lib-dynlink-native/sub/plugin3.ml
index b2d6ca5e..82c9e486 100644
--- a/testsuite/tests/lib-dynlink-native/sub/plugin3.ml
+++ b/testsuite/tests/lib-dynlink-native/sub/plugin3.ml
@@ -1,17 +1,2 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let () =
   ignore (Api.f 10)
diff --git a/testsuite/tests/lib-filename/Makefile b/testsuite/tests/lib-filename/Makefile
new file mode 100644
index 00000000..c11a415f
--- /dev/null
+++ b/testsuite/tests/lib-filename/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-filename/extension.ml b/testsuite/tests/lib-filename/extension.ml
new file mode 100755
index 00000000..917c0146
--- /dev/null
+++ b/testsuite/tests/lib-filename/extension.ml
@@ -0,0 +1,14 @@
+let () =
+  let test f e =
+    assert(Filename.extension f = e);
+    assert(Filename.extension ("foo/" ^ f) = e);
+    assert(f = Filename.remove_extension f ^ Filename.extension f)
+  in
+  test "" "";
+  test "foo" "";
+  test "foo.txt" ".txt";
+  test "foo.txt.gz" ".gz";
+  test ".foo" "";
+  test "." "";
+  test ".." "";
+  test "foo..txt" ".txt"
diff --git a/testsuite/tests/lib-filename/extension.reference b/testsuite/tests/lib-filename/extension.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/lib-format/tformat.ml b/testsuite/tests/lib-format/tformat.ml
index ad0f16cc..ee39a6a7 100644
--- a/testsuite/tests/lib-format/tformat.ml
+++ b/testsuite/tests/lib-format/tformat.ml
@@ -1,15 +1,3 @@
-(*************************************************************************)
-(*                                                                       *)
-(*                                OCaml                                  *)
-(*                                                                       *)
-(*         Pierre Weis, projet Pomdapi, INRIA Rocquencourt               *)
-(*                                                                       *)
-(*   Copyright 2011 Institut National de Recherche en Informatique et    *)
-(*   en Automatique.  All rights reserved.  This file is distributed     *)
-(*   under the terms of the Q Public License version 1.0.                *)
-(*                                                                       *)
-(*************************************************************************)
-
 (*
 
 A test file for the Format module.
diff --git a/testsuite/tests/lib-hashtbl/hfun.ml b/testsuite/tests/lib-hashtbl/hfun.ml
index 0ae427df..4fbb9cfe 100644
--- a/testsuite/tests/lib-hashtbl/hfun.ml
+++ b/testsuite/tests/lib-hashtbl/hfun.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2011 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Testing the hash function Hashtbl.hash *)
 (* What is tested:
      - reproducibility on various platforms, esp. 32/64 bit issues
diff --git a/testsuite/tests/lib-hashtbl/htbl.ml b/testsuite/tests/lib-hashtbl/htbl.ml
index 12550f4d..106ee793 100644
--- a/testsuite/tests/lib-hashtbl/htbl.ml
+++ b/testsuite/tests/lib-hashtbl/htbl.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2011 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Hashtable operations, using maps as a reference *)
 
 open Printf
diff --git a/testsuite/tests/lib-marshal/intext.ml b/testsuite/tests/lib-marshal/intext.ml
index cffa55a1..11633092 100644
--- a/testsuite/tests/lib-marshal/intext.ml
+++ b/testsuite/tests/lib-marshal/intext.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Test for output_value / input_value *)
 
 let max_data_depth = 500000
@@ -329,8 +314,8 @@ let test_buffer () =
      with Failure s when s = "Marshal.to_buffer: buffer overflow" -> true)
 
 let test_size() =
-  let s = Marshal.to_string (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) [] in
-  test 300 (Marshal.header_size + Marshal.data_size s 0 = String.length s)
+  let s = Marshal.to_bytes (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) [] in
+  test 300 (Marshal.header_size + Marshal.data_size s 0 = Bytes.length s)
 
 external marshal_to_block
    : string -> int -> 'a -> Marshal.extern_flags list -> unit
@@ -552,11 +537,48 @@ let test_mutual_rec_regression () =
   test 700 (try ignore (Marshal.to_string f [Marshal.Closures]); true
             with _ -> false)
 
+let test_end_of_file_regression () =
+  (* See PR#7142 *)
+  let write oc n =
+    for k = 0 to n - 1 do
+      Marshal.to_channel oc k []
+    done
+  in
+  let read ic n =
+    let k = ref 0 in
+    try
+      while true do
+        if Marshal.from_channel ic != !k then
+          failwith "unexpected integer";
+        incr k
+      done
+    with
+      | End_of_file when !k != n -> failwith "missing integer"
+      | End_of_file -> ()
+  in
+  test 800 (
+    try
+      let n = 100 in
+      let oc = open_out_bin "intext.data" in
+      write oc n;
+      close_out oc;
+
+      let ic = open_in_bin "intext.data" in
+      try
+        read ic n;
+        close_in ic;
+        true
+      with _ ->
+        close_in ic;
+        false
+    with _ -> false
+  )
+
+
 let main() =
   if Array.length Sys.argv <= 2 then begin
     test_out "intext.data"; test_in "intext.data";
     test_out "intext.data"; test_in "intext.data";
-    Sys.remove "intext.data";
     test_string();
     test_buffer();
     test_size();
@@ -565,6 +587,8 @@ let main() =
     test_objects();
     test_infix ();
     test_mutual_rec_regression ();
+    test_end_of_file_regression ();
+    Sys.remove "intext.data";
   end else
   if Sys.argv.(1) = "make" then begin
     let n = int_of_string Sys.argv.(2) in
diff --git a/testsuite/tests/lib-marshal/intext.reference b/testsuite/tests/lib-marshal/intext.reference
index af16fa37..412cea0c 100644
--- a/testsuite/tests/lib-marshal/intext.reference
+++ b/testsuite/tests/lib-marshal/intext.reference
@@ -171,3 +171,4 @@ Test 605 passed.
 Test 606 passed.
 Test 607 passed.
 Test 700 passed.
+Test 800 passed.
diff --git a/testsuite/tests/lib-marshal/intextaux.c b/testsuite/tests/lib-marshal/intextaux.c
index a1a587ad..f8df141e 100644
--- a/testsuite/tests/lib-marshal/intextaux.c
+++ b/testsuite/tests/lib-marshal/intextaux.c
@@ -16,6 +16,8 @@
 #include 
 #include 
 
+#define CAML_INTERNALS
+
 value marshal_to_block(value vbuf, value vlen, value v, value vflags)
 {
   return Val_long(output_value_to_block(v, vflags,
diff --git a/testsuite/tests/lib-num-2/pi_big_int.ml b/testsuite/tests/lib-num-2/pi_big_int.ml
index acf9af62..22872ba4 100644
--- a/testsuite/tests/lib-num-2/pi_big_int.ml
+++ b/testsuite/tests/lib-num-2/pi_big_int.ml
@@ -1,15 +1,3 @@
-(*************************************************************************)
-(*                                                                       *)
-(*                                 OCaml                                 *)
-(*                                                                       *)
-(*            Pierre Weis, projet Estime, 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.                *)
-(*                                                                       *)
-(*************************************************************************)
-
 (* Pi digits computed with the sreaming algorithm given on pages 4, 6
    & 7 of "Unbounded Spigot Algorithms for the Digits of Pi", Jeremy
    Gibbons, August 2004. *)
diff --git a/testsuite/tests/lib-num-2/pi_num.ml b/testsuite/tests/lib-num-2/pi_num.ml
index a0651a87..e2580c10 100644
--- a/testsuite/tests/lib-num-2/pi_num.ml
+++ b/testsuite/tests/lib-num-2/pi_num.ml
@@ -1,15 +1,3 @@
-(*************************************************************************)
-(*                                                                       *)
-(*                                 OCaml                                 *)
-(*                                                                       *)
-(*            Pierre Weis, projet Estime, 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.                *)
-(*                                                                       *)
-(*************************************************************************)
-
 (* Pi digits computed with the sreaming algorithm given on pages 4, 6
    & 7 of "Unbounded Spigot Algorithms for the Digits of Pi", Jeremy
    Gibbons, August 2004. *)
diff --git a/testsuite/tests/lib-num/end_test.ml b/testsuite/tests/lib-num/end_test.ml
index aee100ae..57e099ed 100644
--- a/testsuite/tests/lib-num/end_test.ml
+++ b/testsuite/tests/lib-num/end_test.ml
@@ -1,16 +1 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*     Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt       *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 Test.end_tests ();;
diff --git a/testsuite/tests/lib-num/test.ml b/testsuite/tests/lib-num/test.ml
index b4a4317e..b45d05d1 100644
--- a/testsuite/tests/lib-num/test.ml
+++ b/testsuite/tests/lib-num/test.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*     Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt       *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Printf;;
 
 let flush_all () = flush stdout; flush stderr;;
@@ -90,6 +75,7 @@ let end_tests () =
 let eq = (==);;
 let eq_int (i: int) (j: int) = (i = j);;
 let eq_string (i: string) (j: string) = (i = j);;
+let eq_bytes (i: bytes) (j: bytes) = (i = j);;
 let eq_nativeint (i: nativeint) (j: nativeint) = (i = j);;
 let eq_int32 (i: int32) (j: int32) = (i = j);;
 let eq_int64 (i: int64) (j: int64) = (i = j);;
diff --git a/testsuite/tests/lib-num/test_big_ints.ml b/testsuite/tests/lib-num/test_big_ints.ml
index 9a99411f..61e4a9f2 100644
--- a/testsuite/tests/lib-num/test_big_ints.ml
+++ b/testsuite/tests/lib-num/test_big_ints.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*     Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt       *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Test;;
 open Nat;;
 open Big_int;;
diff --git a/testsuite/tests/lib-num/test_io.ml b/testsuite/tests/lib-num/test_io.ml
index eee3613f..1df11a5f 100644
--- a/testsuite/tests/lib-num/test_io.ml
+++ b/testsuite/tests/lib-num/test_io.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*     Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt       *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Test
 open Nat
 open Big_int
diff --git a/testsuite/tests/lib-num/test_nats.ml b/testsuite/tests/lib-num/test_nats.ml
index 770a786e..74ce5ecd 100644
--- a/testsuite/tests/lib-num/test_nats.ml
+++ b/testsuite/tests/lib-num/test_nats.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*     Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt       *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Test;;
 open Nat;;
 
@@ -111,8 +96,7 @@ test 2 eq_string (string_of_nat n, "340282366920938463463374607431768211455");;
 testing_function "string_of_nat && nat_of_string";;
 
 for i = 1 to 20 do
-  let s = String.make i '0' in
-  String.set s 0 '1';
+  let s = String.init i (function 0 -> '1' | _ -> '0') in
   ignore (test i eq_string (string_of_nat (nat_of_string s), s))
 done;;
 
diff --git a/testsuite/tests/lib-num/test_nums.ml b/testsuite/tests/lib-num/test_nums.ml
index d78b6a96..e6cd5c9c 100644
--- a/testsuite/tests/lib-num/test_nums.ml
+++ b/testsuite/tests/lib-num/test_nums.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*     Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt       *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Test;;
 open Nat;;
 open Big_int;;
diff --git a/testsuite/tests/lib-num/test_ratios.ml b/testsuite/tests/lib-num/test_ratios.ml
index bb62b835..a5d8fe5e 100644
--- a/testsuite/tests/lib-num/test_ratios.ml
+++ b/testsuite/tests/lib-num/test_ratios.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*     Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt       *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Test;;
 open Nat;;
 open Big_int;;
@@ -980,72 +965,72 @@ msd_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0))
 testing_function "round_futur_last_digit"
 ;;
 
-let s = "+123456" in
-test 1 eq (round_futur_last_digit s 1 (pred (String.length s)),
+let s = Bytes.of_string "+123456" in
+test 1 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
             false) &&
-test 2 eq_string (s, "+123466")
+test 2 eq_bytes (s, Bytes.of_string "+123466")
 ;;
 
-let s = "123456" in
-test 3 eq (round_futur_last_digit s 0 (String.length s), false) &&
-test 4 eq_string (s, "123466")
+let s = Bytes.of_string "123456" in
+test 3 eq (round_futur_last_digit s 0 (Bytes.length s), false) &&
+test 4 eq_bytes (s, Bytes.of_string "123466")
 ;;
 
-let s = "-123456" in
-test 5 eq (round_futur_last_digit s 1 (pred (String.length s)),
+let s = Bytes.of_string "-123456" in
+test 5 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
             false) &&
-test 6 eq_string (s, "-123466")
+test 6 eq_bytes (s, Bytes.of_string "-123466")
 ;;
 
-let s = "+123496" in
-test 7 eq (round_futur_last_digit s 1 (pred (String.length s)),
+let s = Bytes.of_string "+123496" in
+test 7 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
             false) &&
-test 8 eq_string (s, "+123506")
+test 8 eq_bytes (s, Bytes.of_string "+123506")
 ;;
 
-let s = "123496" in
-test 9 eq (round_futur_last_digit s 0 (String.length s), false) &&
-test 10 eq_string (s, "123506")
+let s = Bytes.of_string "123496" in
+test 9 eq (round_futur_last_digit s 0 (Bytes.length s), false) &&
+test 10 eq_bytes (s, Bytes.of_string "123506")
 ;;
 
-let s = "-123496" in
-test 11 eq (round_futur_last_digit s 1 (pred (String.length s)),
+let s = Bytes.of_string "-123496" in
+test 11 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
             false) &&
-test 12 eq_string (s, "-123506")
+test 12 eq_bytes (s, Bytes.of_string "-123506")
 ;;
 
-let s = "+996" in
-test 13 eq (round_futur_last_digit s 1 (pred (String.length s)),
+let s = Bytes.of_string "+996" in
+test 13 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
             true) &&
-test 14 eq_string (s, "+006")
+test 14 eq_bytes (s, Bytes.of_string "+006")
 ;;
 
-let s = "996" in
-test 15 eq (round_futur_last_digit s 0 (String.length s), true) &&
-test 16 eq_string (s, "006")
+let s = Bytes.of_string "996" in
+test 15 eq (round_futur_last_digit s 0 (Bytes.length s), true) &&
+test 16 eq_bytes (s, Bytes.of_string "006")
 ;;
 
-let s = "-996" in
-test 17 eq (round_futur_last_digit s 1 (pred (String.length s)),
+let s = Bytes.of_string "-996" in
+test 17 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
              true) &&
-test 18 eq_string (s, "-006")
+test 18 eq_bytes (s, Bytes.of_string "-006")
 ;;
 
-let s = "+6666666" in
-test 19 eq (round_futur_last_digit s 1 (pred (String.length s)),
+let s = Bytes.of_string "+6666666" in
+test 19 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
              false) &&
-test 20 eq_string (s, "+6666676")
+test 20 eq_bytes (s, Bytes.of_string "+6666676")
 ;;
 
-let s = "6666666" in
-test 21 eq (round_futur_last_digit s 0 (String.length s), false) &&
-test 22 eq_string (s, "6666676")
+let s = Bytes.of_string "6666666" in
+test 21 eq (round_futur_last_digit s 0 (Bytes.length s), false) &&
+test 22 eq_bytes (s, Bytes.of_string "6666676")
 ;;
 
-let s = "-6666666" in
-test 23 eq (round_futur_last_digit s 1 (pred (String.length s)),
+let s = Bytes.of_string "-6666666" in
+test 23 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
              false) &&
-test 24 eq_string (s, "-6666676")
+test 24 eq_bytes (s, Bytes.of_string "-6666676")
 ;;
 
 testing_function "approx_ratio_fix"
diff --git a/testsuite/tests/lib-obj/Makefile b/testsuite/tests/lib-obj/Makefile
new file mode 100755
index 00000000..bb9cfbad
--- /dev/null
+++ b/testsuite/tests/lib-obj/Makefile
@@ -0,0 +1,21 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+MODULES=
+MAIN_MODULE=reachable_words
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-obj/reachable_words.ml b/testsuite/tests/lib-obj/reachable_words.ml
new file mode 100755
index 00000000..68aeca47
--- /dev/null
+++ b/testsuite/tests/lib-obj/reachable_words.ml
@@ -0,0 +1,37 @@
+let native =
+  match Filename.basename Sys.argv.(0) with
+  | "program.byte" | "program.byte.exe" -> false
+  | "program.native" | "program.native.exe" -> true
+  | s -> print_endline s; assert false
+
+
+let size x = Obj.reachable_words (Obj.repr x)
+
+let expect_size s x =
+  let i = size x in
+  if i <> s then
+    Printf.printf "size = %i; expected = %i\n%!" i s
+
+type t =
+  | A of int
+  | B of t * t
+
+let f () =
+  let x = Random.int 10 in
+  expect_size 0 42;
+  expect_size (if native then 0 else 3) (1, 2);
+  expect_size 2 [| x |];
+  expect_size 3 [| x; 0 |];
+
+  let a = A x in
+  expect_size 2 a;
+  expect_size 5 (B (a, a)); (* sharing *)
+  expect_size 7 (B (a, A (x + 1)));
+
+  let rec b = B (a, b) in (* cycle *)
+  expect_size 5 b;
+
+  print_endline "OK"
+
+let () =
+  f ()
diff --git a/testsuite/tests/lib-obj/reachable_words.reference b/testsuite/tests/lib-obj/reachable_words.reference
new file mode 100644
index 00000000..d86bac9d
--- /dev/null
+++ b/testsuite/tests/lib-obj/reachable_words.reference
@@ -0,0 +1 @@
+OK
diff --git a/testsuite/tests/lib-printf/tprintf.ml b/testsuite/tests/lib-printf/tprintf.ml
index 1535d0e3..4ab57230 100644
--- a/testsuite/tests/lib-printf/tprintf.ml
+++ b/testsuite/tests/lib-printf/tprintf.ml
@@ -1,15 +1,3 @@
-(*************************************************************************)
-(*                                                                       *)
-(*                                OCaml                                  *)
-(*                                                                       *)
-(*         Damien Doligez, projet Gallium, INRIA Rocquencourt            *)
-(*                                                                       *)
-(*   Copyright 2011 Institut National de Recherche en Informatique et    *)
-(*   en Automatique.  All rights reserved.  This file is distributed     *)
-(*   under the terms of the Q Public License version 1.0.                *)
-(*                                                                       *)
-(*************************************************************************)
-
 (*
 
 A test file for the Printf module.
diff --git a/testsuite/tests/lib-queue/test.ml b/testsuite/tests/lib-queue/test.ml
index d6acaa60..5574abd8 100644
--- a/testsuite/tests/lib-queue/test.ml
+++ b/testsuite/tests/lib-queue/test.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                  Jeremie Dimino, Jane Street Europe                    *)
-(*                                                                        *)
-(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 module Q = struct
   include Queue
 
diff --git a/testsuite/tests/lib-random/rand.ml b/testsuite/tests/lib-random/rand.ml
index e8c5cb8b..a05761ea 100644
--- a/testsuite/tests/lib-random/rand.ml
+++ b/testsuite/tests/lib-random/rand.ml
@@ -1,6 +1,12 @@
+(* Test that two Random.self_init() in close succession will not result
+   in the same PRNG state.
+   Note that even when the code is correct this test is expected to fail
+   once in 10000 runs.
+*)
+
 let () =
   Random.self_init ();
   let x = Random.int 10000 in
   Random.self_init ();
-  let y = Random.int 1000 in
+  let y = Random.int 10000 in
   if x = y then print_endline "FAILED" else print_endline "PASSED"
diff --git a/testsuite/tests/lib-scanf-2/tscanf2_io.ml b/testsuite/tests/lib-scanf-2/tscanf2_io.ml
index 910df496..03997897 100644
--- a/testsuite/tests/lib-scanf-2/tscanf2_io.ml
+++ b/testsuite/tests/lib-scanf-2/tscanf2_io.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*              Pierre Weis, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2005 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* A very simple communication module using buffers. It should help detecting
    advanced character reading by Scanf when using stdin. *)
 
diff --git a/testsuite/tests/lib-scanf-2/tscanf2_master.ml b/testsuite/tests/lib-scanf-2/tscanf2_master.ml
index 5d7ef316..2dd91bc0 100644
--- a/testsuite/tests/lib-scanf-2/tscanf2_master.ml
+++ b/testsuite/tests/lib-scanf-2/tscanf2_master.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*              Pierre Weis, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2005 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* A very simple master:
    - first launch a slave process,
    - then repeat a random number of times:
diff --git a/testsuite/tests/lib-scanf-2/tscanf2_slave.ml b/testsuite/tests/lib-scanf-2/tscanf2_slave.ml
index a890c6e2..e06a81f8 100644
--- a/testsuite/tests/lib-scanf-2/tscanf2_slave.ml
+++ b/testsuite/tests/lib-scanf-2/tscanf2_slave.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*              Pierre Weis, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2005 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* A very simple slave:
    - read the string " Ping" on stdin,
    - then print the string "-pong" on stderr,
diff --git a/testsuite/tests/lib-scanf/tscanf.ml b/testsuite/tests/lib-scanf/tscanf.ml
index 5eb736d0..421c1b40 100644
--- a/testsuite/tests/lib-scanf/tscanf.ml
+++ b/testsuite/tests/lib-scanf/tscanf.ml
@@ -1,15 +1,3 @@
-(*************************************************************************)
-(*                                                                       *)
-(*                                 OCaml                                 *)
-(*                                                                       *)
-(*            Pierre Weis, projet Cristal, INRIA Rocquencourt            *)
-(*                                                                       *)
-(*   Copyright 2002 Institut National de Recherche en Informatique et    *)
-(*   en Automatique.  All rights reserved.  This file is distributed     *)
-(*   under the terms of the Q Public License version 1.0.                *)
-(*                                                                       *)
-(*************************************************************************)
-
 (*
 
 A testbed file for the module Scanf.
diff --git a/testsuite/tests/lib-set/testmap.ml b/testsuite/tests/lib-set/testmap.ml
index b31456df..bbf4b06a 100644
--- a/testsuite/tests/lib-set/testmap.ml
+++ b/testsuite/tests/lib-set/testmap.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 module M = Map.Make(struct type t = int let compare (x:t) y = compare x y end)
 
 let img x m = try Some(M.find x m) with Not_found -> None
diff --git a/testsuite/tests/lib-set/testset.ml b/testsuite/tests/lib-set/testset.ml
index 6f92c095..4417c36a 100644
--- a/testsuite/tests/lib-set/testset.ml
+++ b/testsuite/tests/lib-set/testset.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 module S = Set.Make(struct type t = int let compare (x:t) y = compare x y end)
 
 let testvals = [0;1;2;3;4;5;6;7;8;9]
@@ -75,6 +60,17 @@ let test x s1 s2 =
     (let b = S.subset s1 s2 in
      b || not (S.is_empty (S.diff s1 s2)));
 
+  checkbool "map"
+    (S.elements (S.map succ s1) = List.map succ (S.elements s1));
+
+  checkbool "map2"
+    (S.map (fun x -> x) s1 == s1);
+
+  checkbool "map3"
+    ((* check that the traversal is made in increasing element order *)
+     let last = ref min_int in
+     S.map (fun x -> assert (!last <= x); last := x; x) s1 == s1);
+
   checkbool "for_all"
     (let p x = x mod 2 = 0 in
      S.for_all p s1 = List.for_all p (S.elements s1));
diff --git a/testsuite/tests/lib-stack/test.ml b/testsuite/tests/lib-stack/test.ml
index e7423107..e0105c50 100644
--- a/testsuite/tests/lib-stack/test.ml
+++ b/testsuite/tests/lib-stack/test.ml
@@ -1,15 +1,3 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                                OCaml                                *)
-(*                                                                     *)
-(*                 Jeremie Dimino, Jane Street Europe                  *)
-(*                                                                     *)
-(*  Copyright 2015 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the S Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
 module S = struct
   include Stack
 
diff --git a/testsuite/tests/lib-str/t01.ml b/testsuite/tests/lib-str/t01.ml
index 679141db..1e1b2705 100644
--- a/testsuite/tests/lib-str/t01.ml
+++ b/testsuite/tests/lib-str/t01.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Printf
 
 let build_result ngroups input =
diff --git a/testsuite/tests/lib-stream/count_concat_bug.ml b/testsuite/tests/lib-stream/count_concat_bug.ml
index 37793891..97ec6bce 100644
--- a/testsuite/tests/lib-stream/count_concat_bug.ml
+++ b/testsuite/tests/lib-stream/count_concat_bug.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Gabriel Scherer, projet Gallium, INRIA Rocquencourt          *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let is_empty s =
   try Stream.empty s; true with Stream.Failure -> false
 
diff --git a/testsuite/tests/lib-string/test_string.ml b/testsuite/tests/lib-string/test_string.ml
index 8fe0521a..96b8c50f 100644
--- a/testsuite/tests/lib-string/test_string.ml
+++ b/testsuite/tests/lib-string/test_string.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                 Damien Doligez, Jane Street Group, LLC                 *)
-(*                                                                        *)
-(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let rec build_string f n accu =
   if n <= 0
     then String.concat "" accu
@@ -36,3 +21,32 @@ let raw_string = build_string char 256 [];;
 let ref_string = build_string reference 256 [];;
 
 if String.escaped raw_string <> ref_string then failwith "test:String.escaped";;
+
+
+let check_split sep s =
+  let l = String.split_on_char sep s in
+  assert(List.length l > 0);
+  assert(String.concat (String.make 1 sep) l = s);
+  List.iter (String.iter (fun c -> assert (c <> sep))) l
+;;
+
+let () =
+  let s = " abc def " in
+  for i = 0 to String.length s do
+    check_split ' ' (String.sub s 0 i)
+  done
+;;
+
+(* GPR#805/815/833 *)
+
+let ()  =
+  if Sys.word_size = 32 then begin
+    let big = String.make Sys.max_string_length 'x' in
+    let push x l = l := x :: !l in
+    let (+=) a b = a := !a + b in
+    let sz, l = ref 0, ref [] in
+    while !sz >= 0 do push big l; sz += Sys.max_string_length done;
+    while !sz <= 0 do push big l; sz += Sys.max_string_length done;
+    try ignore (String.concat "" !l); assert false
+    with Invalid_argument _ -> ()
+  end
diff --git a/testsuite/tests/lib-systhreads/testfork.ml b/testsuite/tests/lib-systhreads/testfork.ml
index 2f019fa3..1c1f232f 100644
--- a/testsuite/tests/lib-systhreads/testfork.ml
+++ b/testsuite/tests/lib-systhreads/testfork.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* POSIX threads and fork() *)
 
 let compute_thread c = ignore c
diff --git a/testsuite/tests/lib-threads/bank.ml b/testsuite/tests/lib-threads/bank.ml
index 7474d983..800d332a 100644
--- a/testsuite/tests/lib-threads/bank.ml
+++ b/testsuite/tests/lib-threads/bank.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* The bank account example, using events and channels *)
 
 open Printf
diff --git a/testsuite/tests/lib-threads/beat.ml b/testsuite/tests/lib-threads/beat.ml
index f269baa7..afc8166a 100644
--- a/testsuite/tests/lib-threads/beat.ml
+++ b/testsuite/tests/lib-threads/beat.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Test Thread.delay and its scheduling *)
 
 open Printf
diff --git a/testsuite/tests/lib-threads/bufchan.ml b/testsuite/tests/lib-threads/bufchan.ml
index a686a94e..b8ac55c2 100644
--- a/testsuite/tests/lib-threads/bufchan.ml
+++ b/testsuite/tests/lib-threads/bufchan.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Event
 
 type 'a buffer_channel = {
diff --git a/testsuite/tests/lib-threads/close.ml b/testsuite/tests/lib-threads/close.ml
index ff6b2b06..3af8ae31 100644
--- a/testsuite/tests/lib-threads/close.ml
+++ b/testsuite/tests/lib-threads/close.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let main () =
   let (rd, wr) = Unix.pipe() in
   let t = Thread.create
diff --git a/testsuite/tests/lib-threads/fileio.ml b/testsuite/tests/lib-threads/fileio.ml
index 370fee0a..f9d97c94 100644
--- a/testsuite/tests/lib-threads/fileio.ml
+++ b/testsuite/tests/lib-threads/fileio.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Test a file copy function *)
 
 let test msg producer consumer src dst =
diff --git a/testsuite/tests/lib-threads/pr4466.ml b/testsuite/tests/lib-threads/pr4466.ml
index 2f7092d7..0598a54e 100644
--- a/testsuite/tests/lib-threads/pr4466.ml
+++ b/testsuite/tests/lib-threads/pr4466.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Gallium, INRIA Paris                  *)
-(*                                                                        *)
-(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Printf
 
 (* Regression test for PR#4466: select timeout with simultaneous read
@@ -27,9 +12,9 @@ open Printf
 *)
 
 let serve_connection s =
-  let buf = String.make 1024 '>' in
+  let buf = Bytes.make 1024 '>' in
   while true do
-    let n = Unix.recv s buf 2 (String.length buf - 2) [] in
+    let n = Unix.recv s buf 2 (Bytes.length buf - 2) [] in
     if n = 0 then begin
       Unix.close s; Thread.exit ()
     end else begin
@@ -44,24 +29,25 @@ let server sock =
   done
 
 let reader s =
-  let buf = String.make 16 ' ' in
+  let buf = Bytes.make 16 ' ' in
   match Unix.select [s] [] [] 10.0 with
   | (_::_, _, _) ->
       printf "Selected\n%!";
-      let n = Unix.recv s buf 0 (String.length buf) [] in
-      printf "Data read: %s\n%!" (String.sub buf 0 n)
+      let n = Unix.recv s buf 0 (Bytes.length buf) [] in
+      printf "Data read: %s\n%!" (Bytes.sub_string buf 0 n)
   | ([], _, _) ->
       printf "TIMEOUT\n%!"
 
 let writer s msg =
-  ignore (Unix.send s msg 0 (String.length msg) [])
+  ignore (Unix.send_substring s msg 0 (String.length msg) [])
 
 let _ =
-  let addr = Unix.ADDR_INET(Unix.inet_addr_loopback, 9876) in
+  let addr = Unix.ADDR_INET(Unix.inet_addr_loopback, 0) in
   let serv =
     Unix.socket (Unix.domain_of_sockaddr addr) Unix.SOCK_STREAM 0 in
   Unix.setsockopt serv Unix.SO_REUSEADDR true;
   Unix.bind serv addr;
+  let addr = Unix.getsockname serv in
   Unix.listen serv 5;
   ignore (Thread.create server serv);
   Thread.delay 0.2;
diff --git a/testsuite/tests/lib-threads/pr5325.ml b/testsuite/tests/lib-threads/pr5325.ml
index 508eb4a4..884a9a3e 100644
--- a/testsuite/tests/lib-threads/pr5325.ml
+++ b/testsuite/tests/lib-threads/pr5325.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Gallium, INRIA Paris                  *)
-(*                                                                        *)
-(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Printf
 
 (* Regression test for PR#5325: simultaneous read and write on socket
@@ -28,8 +13,8 @@ open Printf
 *)
 
 let serve_connection s =
-  let buf = String.make 1024 '>' in
-  let n = Unix.read s buf 2 (String.length buf - 2) in
+  let buf = Bytes.make 1024 '>' in
+  let n = Unix.read s buf 2 (Bytes.length buf - 2) in
   ignore (Unix.write s buf 0 (n + 2));
   Unix.close s
 
@@ -45,20 +30,21 @@ let timeout () =
   exit 2
 
 let reader s =
-  let buf = String.make 1024 ' ' in
-  let n = Unix.read s buf 0 (String.length buf) in
-  print_string (String.sub buf 0 n); flush stdout
+  let buf = Bytes.make 1024 ' ' in
+  let n = Unix.read s buf 0 (Bytes.length buf) in
+  print_bytes (Bytes.sub buf 0 n); flush stdout
 
 let writer s msg =
-  ignore (Unix.write s msg 0 (String.length msg));
+  ignore (Unix.write_substring s msg 0 (String.length msg));
   Unix.shutdown s Unix.SHUTDOWN_SEND
 
 let _ =
-  let addr = Unix.ADDR_INET(Unix.inet_addr_loopback, 9876) in
+  let addr = Unix.ADDR_INET(Unix.inet_addr_loopback, 0) in
   let serv =
     Unix.socket (Unix.domain_of_sockaddr addr) Unix.SOCK_STREAM 0 in
   Unix.setsockopt serv Unix.SO_REUSEADDR true;
   Unix.bind serv addr;
+  let addr = Unix.getsockname serv in
   Unix.listen serv 5;
   ignore (Thread.create server serv);
   ignore (Thread.create timeout ());
diff --git a/testsuite/tests/lib-threads/prodcons.ml b/testsuite/tests/lib-threads/prodcons.ml
index e243ce0f..81e3ff18 100644
--- a/testsuite/tests/lib-threads/prodcons.ml
+++ b/testsuite/tests/lib-threads/prodcons.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Classic producer-consumer *)
 
 type 'a prodcons =
diff --git a/testsuite/tests/lib-threads/prodcons2.ml b/testsuite/tests/lib-threads/prodcons2.ml
index 6133e07b..0b80f5e2 100644
--- a/testsuite/tests/lib-threads/prodcons2.ml
+++ b/testsuite/tests/lib-threads/prodcons2.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Producer-consumer with events and multiple producers *)
 
 open Event
diff --git a/testsuite/tests/lib-threads/sieve.ml b/testsuite/tests/lib-threads/sieve.ml
index 6cee51a1..13c494cd 100644
--- a/testsuite/tests/lib-threads/sieve.ml
+++ b/testsuite/tests/lib-threads/sieve.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let sieve primes =
   Event.sync (Event.send primes 2);
   let integers = Event.new_channel () in
diff --git a/testsuite/tests/lib-threads/sigint.c b/testsuite/tests/lib-threads/sigint.c
index 4a5cac63..a975949a 100644
--- a/testsuite/tests/lib-threads/sigint.c
+++ b/testsuite/tests/lib-threads/sigint.c
@@ -15,14 +15,14 @@ int main(int argc, char** argv)
   hProcess = OpenProcess(SYNCHRONIZE, FALSE, pid);
 
   if (!hProcess) {
-    printf("Process %ul not found!\n", pid);
+    printf("Process %lu not found!\n", pid);
     return 1;
   }
 
   FreeConsole();
 
   if (!AttachConsole(pid)) {
-    printf("Failed to attach to console of Process %ul\n", pid);
+    printf("Failed to attach to console of Process %lu\n", pid);
     CloseHandle(hProcess);
     return 1;
   }
diff --git a/testsuite/tests/lib-threads/signal.ml b/testsuite/tests/lib-threads/signal.ml
index e067ea06..b9ef7d63 100644
--- a/testsuite/tests/lib-threads/signal.ml
+++ b/testsuite/tests/lib-threads/signal.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let sighandler _ =
   print_string "Got ctrl-C, exiting..."; print_newline();
   exit 0
diff --git a/testsuite/tests/lib-threads/signal2.ml b/testsuite/tests/lib-threads/signal2.ml
index 79e984e2..b7cda56d 100644
--- a/testsuite/tests/lib-threads/signal2.ml
+++ b/testsuite/tests/lib-threads/signal2.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let print_message delay c =
   while true do
     print_char c; flush stdout; Thread.delay delay
diff --git a/testsuite/tests/lib-threads/sockets.ml b/testsuite/tests/lib-threads/sockets.ml
index b4adec36..160446f6 100644
--- a/testsuite/tests/lib-threads/sockets.ml
+++ b/testsuite/tests/lib-threads/sockets.ml
@@ -1,25 +1,10 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Printf
 
 (* Threads and sockets *)
 
 let serve_connection s =
-  let buf = String.make 1024 '>' in
-  let n = Unix.read s buf 2 (String.length buf - 2) in
+  let buf = Bytes.make 1024 '>' in
+  let n = Unix.read s buf 2 (Bytes.length buf - 2) in
   Thread.delay 1.0;
   ignore (Unix.write s buf 0 (n + 2));
   Unix.close s
@@ -34,17 +19,18 @@ let client (addr, msg) =
   let sock =
     Unix.socket (Unix.domain_of_sockaddr addr) Unix.SOCK_STREAM 0 in
   Unix.connect sock addr;
-  let buf = String.make 1024 ' ' in
-  ignore(Unix.write sock msg 0 (String.length msg));
-  let n = Unix.read sock buf 0 (String.length buf) in
-  print_string (String.sub buf 0 n); flush stdout
+  let buf = Bytes.make 1024 ' ' in
+  ignore(Unix.write_substring sock msg 0 (String.length msg));
+  let n = Unix.read sock buf 0 (Bytes.length buf) in
+  print_bytes (Bytes.sub buf 0 n); flush stdout
 
 let _ =
-  let addr = Unix.ADDR_INET(Unix.inet_addr_loopback, 9876) in
+  let addr = Unix.ADDR_INET(Unix.inet_addr_loopback, 0) in
   let sock =
     Unix.socket (Unix.domain_of_sockaddr addr) Unix.SOCK_STREAM 0 in
   Unix.setsockopt sock Unix.SO_REUSEADDR true;
   Unix.bind sock addr;
+  let addr = Unix.getsockname sock in
   Unix.listen sock 5;
   ignore (Thread.create server sock);
   ignore (Thread.create client (addr, "Client #1\n"));
diff --git a/testsuite/tests/lib-threads/socketsbuf.ml b/testsuite/tests/lib-threads/socketsbuf.ml
index d23d33e3..7eafb1bd 100644
--- a/testsuite/tests/lib-threads/socketsbuf.ml
+++ b/testsuite/tests/lib-threads/socketsbuf.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Printf
 
 (* Threads, sockets, and buffered I/O channels *)
@@ -42,11 +27,12 @@ let client (addr, msg) =
   printf "%s\n%!" l
 
 let _ =
-  let addr = Unix.ADDR_INET(Unix.inet_addr_loopback, 9876) in
+  let addr = Unix.ADDR_INET(Unix.inet_addr_loopback, 0) in
   let sock =
     Unix.socket (Unix.domain_of_sockaddr addr) Unix.SOCK_STREAM 0 in
   Unix.setsockopt sock Unix.SO_REUSEADDR true;
   Unix.bind sock addr;
+  let addr = Unix.getsockname sock in
   Unix.listen sock 5;
   ignore (Thread.create server sock);
   ignore (Thread.create client (addr, "Client #1\n"));
diff --git a/testsuite/tests/lib-threads/swapchan.ml b/testsuite/tests/lib-threads/swapchan.ml
index 8074b610..1f80beb8 100644
--- a/testsuite/tests/lib-threads/swapchan.ml
+++ b/testsuite/tests/lib-threads/swapchan.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Event
 
 type 'a swap_chan = ('a * 'a channel) channel
diff --git a/testsuite/tests/lib-threads/tls.ml b/testsuite/tests/lib-threads/tls.ml
index 0f51b9d5..6db93fa9 100644
--- a/testsuite/tests/lib-threads/tls.ml
+++ b/testsuite/tests/lib-threads/tls.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let private_data = (Hashtbl.create 17 : (Thread.t, string) Hashtbl.t)
 let private_data_lock = Mutex.create()
 let output_lock = Mutex.create()
diff --git a/testsuite/tests/lib-threads/torture.ml b/testsuite/tests/lib-threads/torture.ml
index 82908d24..9dba8add 100644
--- a/testsuite/tests/lib-threads/torture.ml
+++ b/testsuite/tests/lib-threads/torture.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Torture test - I/O interspersed with lots of GC *)
 
 let finished = ref false
@@ -27,21 +12,21 @@ let gc_thread () =
 let writer_thread (oc, size) =
   while not !finished do
 (*    print_string "writer "; print_int size; print_newline(); *)
-    let buff = String.make size 'a' in
+    let buff = Bytes.make size 'a' in
     ignore(Unix.write oc buff 0 size)
   done;
-  let buff = String.make size 'b' in
+  let buff = Bytes.make size 'b' in
   ignore (Unix.write oc buff 0 size)
 
 let reader_thread (ic, size) =
   while true do
 (*    print_string "reader "; print_int size; print_newline(); *)
-    let buff = String.make size ' ' in
+    let buff = Bytes.make size ' ' in
     let n = Unix.read ic buff 0 size in
 (*    print_string "reader "; print_int n; print_newline(); *)
     for i = 0 to n-1 do
-      if buff.[i] = 'b' then Thread.exit()
-      else if buff.[i] <> 'a' then print_string "error in reader_thread\n"
+      if Bytes.get buff i = 'b' then Thread.exit()
+      else if Bytes.get buff i <> 'a' then print_string "error in reader_thread\n"
     done
   done
 
diff --git a/testsuite/tests/lib-uchar/test.ml b/testsuite/tests/lib-uchar/test.ml
index f7e37725..a2b7ec1d 100644
--- a/testsuite/tests/lib-uchar/test.ml
+++ b/testsuite/tests/lib-uchar/test.ml
@@ -1,19 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                            Daniel C. Buenzli                           *)
-(*                                                                        *)
-(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-
 let assert_raise_invalid_argument f v =
   assert (try ignore (f v); false with Invalid_argument _ -> true)
 
diff --git a/testsuite/tests/link-test/Makefile b/testsuite/tests/link-test/Makefile
index d1ee0c24..8ac2e18b 100644
--- a/testsuite/tests/link-test/Makefile
+++ b/testsuite/tests/link-test/Makefile
@@ -14,22 +14,45 @@
 #*                                                                        *
 #**************************************************************************
 
-default:
-	printf " ... testing 'test.reference':"
+default: byte native
+
+native:
+	@printf " ... testing native 'test.reference':"
 	@$(OCAMLOPT) -c submodule.ml
 	@$(OCAMLOPT) -c aliases.ml
+	@$(OCAMLOPT) -c external.mli external.ml
+	@$(OCAMLOPT) -c external_for_pack.mli external_for_pack.ml
 	@$(OCAMLOPT) -c test.ml
-	@$(OCAMLOPT) -a submodule.cmx aliases.cmx -o mylib.cmxa
-	@$(OCAMLOPT) mylib.cmxa test.cmx -o test.native
+	@$(OCAMLOPT) -a submodule.cmx aliases.cmx external.cmx \
+		external_for_pack.cmx -o mylib.cmxa
+	@$(OCAMLOPT) -c -for-pack P use_in_pack.ml
+	@$(OCAMLOPT) -pack use_in_pack.cmx -o p.cmx
+	@$(OCAMLOPT) mylib.cmxa p.cmx test.cmx -o test.native
 	@./test.native > test.result
 	@$(DIFF) test.result test.reference >/dev/null \
 	    && echo " => passed" || echo " => failed"
 
+byte:
+	@printf " ... testing byte 'test.reference':"
+	@$(OCAMLC) -c submodule.ml
+	@$(OCAMLC) -c aliases.ml
+	@$(OCAMLC) -c external.mli external.ml
+	@$(OCAMLC) -c external_for_pack.mli external_for_pack.ml
+	@$(OCAMLC) -c test.ml
+	@$(OCAMLC) -a submodule.cmo aliases.cmo external.cmo \
+		external_for_pack.cmo -o mylib.cma
+	@$(OCAMLC) -c -for-pack P use_in_pack.ml
+	@$(OCAMLC) -pack use_in_pack.cmo -o p.cmo
+	@$(OCAMLC) mylib.cma p.cmo test.cmo -o test.byte
+	@$(OCAMLRUN) ./test.byte > test.result
+	@$(DIFF) test.result test.reference >/dev/null \
+	    && echo " => passed" || echo " => failed"
+
 promote: defaultpromote
 
 clean: defaultclean
 	@rm -f *.result
-	@rm -f test.native
+	@rm -f test.native test.byte
 
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/link-test/external.ml b/testsuite/tests/link-test/external.ml
new file mode 100644
index 00000000..e2eb5b7f
--- /dev/null
+++ b/testsuite/tests/link-test/external.ml
@@ -0,0 +1,2 @@
+let () = print_endline "linked external"; flush stdout
+external frexp : float -> float * int = "caml_frexp_float"
diff --git a/testsuite/tests/link-test/external.mli b/testsuite/tests/link-test/external.mli
new file mode 100644
index 00000000..4b2548e8
--- /dev/null
+++ b/testsuite/tests/link-test/external.mli
@@ -0,0 +1 @@
+external frexp : float -> float * int = "caml_frexp_float"
diff --git a/testsuite/tests/link-test/external_for_pack.ml b/testsuite/tests/link-test/external_for_pack.ml
new file mode 100644
index 00000000..2d5be97c
--- /dev/null
+++ b/testsuite/tests/link-test/external_for_pack.ml
@@ -0,0 +1,2 @@
+let () = print_endline "linked external from pack"; flush stdout
+external frexp : float -> float * int = "caml_frexp_float"
diff --git a/testsuite/tests/link-test/external_for_pack.mli b/testsuite/tests/link-test/external_for_pack.mli
new file mode 100644
index 00000000..4b2548e8
--- /dev/null
+++ b/testsuite/tests/link-test/external_for_pack.mli
@@ -0,0 +1 @@
+external frexp : float -> float * int = "caml_frexp_float"
diff --git a/testsuite/tests/link-test/test.ml b/testsuite/tests/link-test/test.ml
index 80190b83..24d870ac 100644
--- a/testsuite/tests/link-test/test.ml
+++ b/testsuite/tests/link-test/test.ml
@@ -1 +1,2 @@
 include Aliases.Submodule.M
+let _, _ = External.frexp 3.
diff --git a/testsuite/tests/link-test/test.reference b/testsuite/tests/link-test/test.reference
index 1fb9bdd6..b188f6c0 100644
--- a/testsuite/tests/link-test/test.reference
+++ b/testsuite/tests/link-test/test.reference
@@ -1 +1,3 @@
 linked
+linked external
+linked external from pack
diff --git a/testsuite/tests/link-test/use_in_pack.ml b/testsuite/tests/link-test/use_in_pack.ml
new file mode 100644
index 00000000..9d55b593
--- /dev/null
+++ b/testsuite/tests/link-test/use_in_pack.ml
@@ -0,0 +1 @@
+let _, _ = External_for_pack.frexp 12.
diff --git a/testsuite/tests/manual-intf-c/Makefile b/testsuite/tests/manual-intf-c/Makefile
new file mode 100644
index 00000000..4601ff99
--- /dev/null
+++ b/testsuite/tests/manual-intf-c/Makefile
@@ -0,0 +1,40 @@
+# Tests from manual, section intf-c
+# main.ml: error message when equality is missing
+# main_ok.ml: allow path expansion even when the target is missing (GPR#816)
+
+SOURCES = curses.ml prog.ml
+CSOURCES = curses_stubs.c
+CLIBS = -cclib "$(BYTECCLIBS)"
+LIBUNIX = -I $(BASEDIR)/../otherlibs/unix unix.cma
+
+# Disable this test until we figure out how to test for the availability
+# of curses.
+.PHONY: disable
+disable:
+	@printf " ... testing prog => skipped\n"
+	@printf " ... testing prog2 => skipped\n"
+
+.PHONY: default
+default: clean $(SOURCES) $(CSOURCES)
+	@printf " ... testing prog"
+	@$(MAKE) prog > /dev/null && echo " => passed" || echo " => failed"
+	@printf " ... testing prog2"
+	@$(MAKE) prog2 REDIRECT=">prog2.result 2>&1" \
+	  >/dev/null 2>/dev/null || :
+	@$(DIFF) prog2.reference prog2.result >/dev/null \
+	&& echo " => passed" || echo " => failed"
+
+# Should succeed
+prog:
+	$(OCAMLC) -custom -o prog $(LIBUNIX) $(SOURCES) $(CSOURCES) $(CLIBS)
+
+# Should fail
+prog2:  curses.cmo
+	$(OCAMLC) -custom -o prog2 $(LIBUNIX) prog.ml $(CSOURCES) $(CLIBS) $(REDIRECT)
+
+.PHONY: clean
+clean:
+	@rm -f *.cm* *.o *~ prog prog2
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/manual-intf-c/curses.ml b/testsuite/tests/manual-intf-c/curses.ml
new file mode 100644
index 00000000..1447f6bf
--- /dev/null
+++ b/testsuite/tests/manual-intf-c/curses.ml
@@ -0,0 +1,13 @@
+(* File curses.ml -- declaration of primitives and data types *)
+type window                   (* The type "window" remains abstract *)
+external initscr: unit -> window = "caml_curses_initscr"
+external endwin: unit -> unit = "caml_curses_endwin"
+external refresh: unit -> unit = "caml_curses_refresh"
+external wrefresh : window -> unit = "caml_curses_wrefresh"
+external newwin: int -> int -> int -> int -> window = "caml_curses_newwin"
+external addch: char -> unit = "caml_curses_addch"
+external mvwaddch: window -> int -> int -> char -> unit = "caml_curses_mvwaddch"
+external addstr: string -> unit = "caml_curses_addstr"
+external mvwaddstr: window -> int -> int -> string -> unit
+         = "caml_curses_mvwaddstr"
+(* lots more omitted *)
diff --git a/testsuite/tests/manual-intf-c/curses_stubs.c b/testsuite/tests/manual-intf-c/curses_stubs.c
new file mode 100644
index 00000000..33c74a87
--- /dev/null
+++ b/testsuite/tests/manual-intf-c/curses_stubs.c
@@ -0,0 +1,94 @@
+/* File curses_stubs.c -- stub code for curses */
+#include 
+#include 
+#include 
+#include 
+#include 
+
+/* Encapsulation of opaque window handles (of type WINDOW *)
+   as OCaml custom blocks. */
+
+static struct custom_operations curses_window_ops = {
+  "fr.inria.caml.curses_windows",
+  custom_finalize_default,
+  custom_compare_default,
+  custom_hash_default,
+  custom_serialize_default,
+  custom_deserialize_default,
+  custom_compare_ext_default
+};
+
+/* Accessing the WINDOW * part of an OCaml custom block */
+#define Window_val(v) (*((WINDOW **) Data_custom_val(v)))
+
+/* Allocating an OCaml custom block to hold the given WINDOW * */
+static value alloc_window(WINDOW * w)
+{
+  value v = alloc_custom(&curses_window_ops, sizeof(WINDOW *), 0, 1);
+  Window_val(v) = w;
+  return v;
+}
+
+value caml_curses_initscr(value unit)
+{
+  CAMLparam1 (unit);
+  CAMLreturn (alloc_window(initscr()));
+}
+
+value caml_curses_endwin(value unit)
+{
+  CAMLparam1 (unit);
+  endwin();
+  CAMLreturn (Val_unit);
+}
+
+value caml_curses_refresh(value unit)
+{
+  CAMLparam1 (unit);
+  refresh();
+  CAMLreturn (Val_unit);
+}
+
+value caml_curses_wrefresh(value win)
+{
+  CAMLparam1 (win);
+  wrefresh(Window_val(win));
+  CAMLreturn (Val_unit);
+}
+
+value caml_curses_newwin(value nlines, value ncols, value x0, value y0)
+{
+  CAMLparam4 (nlines, ncols, x0, y0);
+  CAMLreturn (alloc_window(newwin(Int_val(nlines), Int_val(ncols),
+                                  Int_val(x0), Int_val(y0))));
+}
+
+value caml_curses_addch(value c)
+{
+  CAMLparam1 (c);
+  addch(Int_val(c));            /* Characters are encoded like integers */
+  CAMLreturn (Val_unit);
+}
+
+value caml_curses_mvwaddch(value win, value x, value y, value c)
+{
+  CAMLparam4 (win, x, y, c);
+  mvwaddch(Window_val(win), Int_val(x), Int_val(y), Int_val(c));
+  CAMLreturn (Val_unit);
+}
+
+value caml_curses_addstr(value s)
+{
+  CAMLparam1 (s);
+  addstr(String_val(s));
+  CAMLreturn (Val_unit);
+}
+
+value caml_curses_mvwaddstr(value win, value x, value y, value s)
+{
+  CAMLparam4 (win, x, y, s);
+  mvwaddstr(Window_val(win), Int_val(x), Int_val(y), String_val(s));
+  CAMLreturn (Val_unit);
+}
+
+/* This goes on for pages. */
diff --git a/testsuite/tests/manual-intf-c/prog.ml b/testsuite/tests/manual-intf-c/prog.ml
new file mode 100644
index 00000000..a913fd91
--- /dev/null
+++ b/testsuite/tests/manual-intf-c/prog.ml
@@ -0,0 +1,9 @@
+(* File prog.ml -- main program using curses *)
+open Curses;;
+let main_window = initscr () in
+let small_window = newwin 10 5 20 10 in
+  mvwaddstr main_window 10 2 "Hello";
+  mvwaddstr small_window 4 3 "world";
+  refresh();
+  Unix.sleep 5;
+  endwin()
diff --git a/testsuite/tests/manual-intf-c/prog2.reference b/testsuite/tests/manual-intf-c/prog2.reference
new file mode 100644
index 00000000..06f5553f
--- /dev/null
+++ b/testsuite/tests/manual-intf-c/prog2.reference
@@ -0,0 +1,2 @@
+File "curses_stubs.c", line 1:
+Error: Required module `Curses' is unavailable
diff --git a/testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml.reference b/testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml.reference
index f1e30bc5..69ba3a45 100644
--- a/testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml.reference
+++ b/testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml.reference
@@ -5,7 +5,7 @@
       | Some false -> ()
       | None -> ()
 Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
+Here is an example of a case that is not matched:
 Some true
 val test_match_exhaustiveness : unit -> unit = 
 # 
diff --git a/testsuite/tests/misc-kb/equations.ml b/testsuite/tests/misc-kb/equations.ml
index 6e28aa08..c8dbff05 100644
--- a/testsuite/tests/misc-kb/equations.ml
+++ b/testsuite/tests/misc-kb/equations.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (****************** Equation manipulations *************)
 
 open Terms
diff --git a/testsuite/tests/misc-kb/equations.mli b/testsuite/tests/misc-kb/equations.mli
index 81a6ec45..99055ce2 100644
--- a/testsuite/tests/misc-kb/equations.mli
+++ b/testsuite/tests/misc-kb/equations.mli
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Terms
 
 type rule =
diff --git a/testsuite/tests/misc-kb/kb.ml b/testsuite/tests/misc-kb/kb.ml
index bb0e4391..1e5fd2c7 100644
--- a/testsuite/tests/misc-kb/kb.ml
+++ b/testsuite/tests/misc-kb/kb.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Terms
 open Equations
 
diff --git a/testsuite/tests/misc-kb/kb.mli b/testsuite/tests/misc-kb/kb.mli
index 78bbba5c..32768716 100644
--- a/testsuite/tests/misc-kb/kb.mli
+++ b/testsuite/tests/misc-kb/kb.mli
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Terms
 open Equations
 
diff --git a/testsuite/tests/misc-kb/kbmain.ml b/testsuite/tests/misc-kb/kbmain.ml
index b8aff7ce..e5c53dc8 100644
--- a/testsuite/tests/misc-kb/kbmain.ml
+++ b/testsuite/tests/misc-kb/kbmain.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Terms
 open Equations
 open Orderings
diff --git a/testsuite/tests/misc-kb/orderings.ml b/testsuite/tests/misc-kb/orderings.ml
index 2646e835..b6ef8abf 100644
--- a/testsuite/tests/misc-kb/orderings.ml
+++ b/testsuite/tests/misc-kb/orderings.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (*********************** Recursive Path Ordering ****************************)
 
 open Terms
diff --git a/testsuite/tests/misc-kb/orderings.mli b/testsuite/tests/misc-kb/orderings.mli
index 2bc41e96..d0493c52 100644
--- a/testsuite/tests/misc-kb/orderings.mli
+++ b/testsuite/tests/misc-kb/orderings.mli
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Terms
 
 type ordering =
diff --git a/testsuite/tests/misc-kb/terms.ml b/testsuite/tests/misc-kb/terms.ml
index b1e95311..f66c86fa 100644
--- a/testsuite/tests/misc-kb/terms.ml
+++ b/testsuite/tests/misc-kb/terms.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (****************** Term manipulations *****************)
 
 type term =
diff --git a/testsuite/tests/misc-kb/terms.mli b/testsuite/tests/misc-kb/terms.mli
index 90da1a8c..81ec58e7 100644
--- a/testsuite/tests/misc-kb/terms.mli
+++ b/testsuite/tests/misc-kb/terms.mli
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 type term =
     Var of int
   | Term of string * term list
diff --git a/testsuite/tests/misc-unsafe/fft.ml b/testsuite/tests/misc-unsafe/fft.ml
index 3e3024ee..7c030a85 100644
--- a/testsuite/tests/misc-unsafe/fft.ml
+++ b/testsuite/tests/misc-unsafe/fft.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let pi = 3.14159265358979323846
 
 let tpi = 2.0 *. pi
diff --git a/testsuite/tests/misc-unsafe/quicksort.ml b/testsuite/tests/misc-unsafe/quicksort.ml
index 9835d699..21491b70 100644
--- a/testsuite/tests/misc-unsafe/quicksort.ml
+++ b/testsuite/tests/misc-unsafe/quicksort.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Good test for loops. Best compiled with -unsafe. *)
 
 let rec qsort lo hi (a : int array) =
diff --git a/testsuite/tests/misc-unsafe/soli.ml b/testsuite/tests/misc-unsafe/soli.ml
index bdf1e1ed..ccab81e0 100644
--- a/testsuite/tests/misc-unsafe/soli.ml
+++ b/testsuite/tests/misc-unsafe/soli.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 type peg = Out | Empty | Peg
 
 let board = [|
diff --git a/testsuite/tests/misc/bdd.ml b/testsuite/tests/misc/bdd.ml
index 684202ad..ce7d931d 100644
--- a/testsuite/tests/misc/bdd.ml
+++ b/testsuite/tests/misc/bdd.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Translated to OCaml by Xavier Leroy *)
 (* Original code written in SML by ... *)
 
diff --git a/testsuite/tests/misc/boyer.ml b/testsuite/tests/misc/boyer.ml
index 257cdea8..38b0a4bd 100644
--- a/testsuite/tests/misc/boyer.ml
+++ b/testsuite/tests/misc/boyer.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Manipulations over terms *)
 
 type term =
diff --git a/testsuite/tests/misc/ephetest.ml b/testsuite/tests/misc/ephetest.ml
index 6aa9ca01..a125300c 100644
--- a/testsuite/tests/misc/ephetest.ml
+++ b/testsuite/tests/misc/ephetest.ml
@@ -1,15 +1,3 @@
-(*************************************************************************)
-(*                                                                       *)
-(*                                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
diff --git a/testsuite/tests/misc/ephetest2.ml b/testsuite/tests/misc/ephetest2.ml
index d1da4486..61861df9 100644
--- a/testsuite/tests/misc/ephetest2.ml
+++ b/testsuite/tests/misc/ephetest2.ml
@@ -1,15 +1,3 @@
-(*************************************************************************)
-(*                                                                       *)
-(*                                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:
diff --git a/testsuite/tests/misc/ephetest3.ml b/testsuite/tests/misc/ephetest3.ml
index 3c49b47f..5eed2cf3 100644
--- a/testsuite/tests/misc/ephetest3.ml
+++ b/testsuite/tests/misc/ephetest3.ml
@@ -1,15 +1,3 @@
-(*************************************************************************)
-(*                                                                       *)
-(*                                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 *)
 
diff --git a/testsuite/tests/misc/fib.ml b/testsuite/tests/misc/fib.ml
index 5c7c9dc2..15228173 100644
--- a/testsuite/tests/misc/fib.ml
+++ b/testsuite/tests/misc/fib.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let rec fib n =
   if n < 2 then 1 else fib(n-1) + fib(n-2)
 
diff --git a/testsuite/tests/misc/finaliser.ml b/testsuite/tests/misc/finaliser.ml
new file mode 100644
index 00000000..316c0da1
--- /dev/null
+++ b/testsuite/tests/misc/finaliser.ml
@@ -0,0 +1,68 @@
+
+
+let m = 1000
+let m' = 100
+let k = m*10
+
+(** the printing are not stable between ocamlc and ocamlopt *)
+let debug = false
+
+let gc_print where _ =
+  if debug then
+    let stat = Gc.quick_stat () in
+    Printf.printf "minor: %i major: %i %s\n%!"
+      stat.Gc.minor_collections
+      stat.Gc.major_collections
+      where
+
+let r = Array.init m (fun _ -> Array.make m 1)
+
+
+let () =
+  gc_print "[Before]" ();
+  let rec aux n =
+    if n < k then begin
+      r.(n mod m) <- (Array.make m' n);
+      begin match n mod m with
+      | 0 ->
+          (** finalise first major *)
+          gc_print (Printf.sprintf "[Create %i first]" n) ();
+          Gc.finalise (gc_print (Printf.sprintf "[Finalise %i first]" n)) r.(0)
+      | 1 ->
+          (** finalise last major *)
+          gc_print (Printf.sprintf "[Create %i last]" n) ();
+          Gc.finalise_last
+            (gc_print (Printf.sprintf "[Finalise %i last]" n)) r.(1)
+      | 2 ->
+          (** finalise first minor *)
+          let m = ref 1 in
+          gc_print (Printf.sprintf "[Create %i first minor]" n) ();
+          Gc.finalise
+            (gc_print (Printf.sprintf "[Finalise %i first minor]" n)) m
+      | 3 ->
+          (** finalise last minor *)
+          let m = ref 1 in
+          gc_print (Printf.sprintf "[Create %i last minor]" n) ();
+          Gc.finalise_last
+            (gc_print (Printf.sprintf "[Finalise %i last minor]" n)) m
+      | 4 ->
+          (** finalise first-last major *)
+          gc_print (Printf.sprintf "[Create %i first]" n) ();
+          Gc.finalise (gc_print (Printf.sprintf "[Finalise %i first]" n)) r.(4);
+          Gc.finalise_last
+            (gc_print (Printf.sprintf "[Finalise %i first]" n)) r.(4)
+      | _ -> ()
+      end;
+      aux (n + 1)
+    end
+  in
+  aux 0;
+  gc_print "[Full major]" ();
+  Gc.full_major ();
+  gc_print "[Second full major]" ();
+  Gc.full_major ();
+  gc_print "[Third full major]" ();
+  Gc.full_major ();
+  ()
+
+let () = flush stdout
diff --git a/testsuite/tests/misc/finaliser.reference b/testsuite/tests/misc/finaliser.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/misc/hamming.ml b/testsuite/tests/misc/hamming.ml
index 885d2752..c98dea3d 100644
--- a/testsuite/tests/misc/hamming.ml
+++ b/testsuite/tests/misc/hamming.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Damien Doligez, projet Moscova, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* We cannot use bignums because we don't do custom runtimes, but
    int64 is a bit short, so we roll our own 37-digit numbers...
 *)
diff --git a/testsuite/tests/misc/nucleic.ml b/testsuite/tests/misc/nucleic.ml
index 55647e15..a31b4166 100644
--- a/testsuite/tests/misc/nucleic.ml
+++ b/testsuite/tests/misc/nucleic.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Use floating-point arithmetic *)
 
 external (+) : float -> float -> float = "%addfloat"
diff --git a/testsuite/tests/misc/sieve.ml b/testsuite/tests/misc/sieve.ml
index 54df6e28..0b9ac4c9 100644
--- a/testsuite/tests/misc/sieve.ml
+++ b/testsuite/tests/misc/sieve.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Eratosthene's sieve *)
 
 (* interval min max = [min; min+1; ...; max-1; max] *)
diff --git a/testsuite/tests/misc/sorts.ml b/testsuite/tests/misc/sorts.ml
index 40a0fbb2..4c4d7126 100644
--- a/testsuite/tests/misc/sorts.ml
+++ b/testsuite/tests/misc/sorts.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Damien Doligez, projet Moscova, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2000 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Test bench for sorting algorithms. *)
 
 
@@ -135,8 +120,8 @@ let chkfloats rstate n a =
 ;;
 
 type record = {
-  s1 : string;
-  s2 : string;
+  s1 : bytes;
+  s2 : bytes;
   i1 : int;
   i2 : int;
 };;
diff --git a/testsuite/tests/misc/takc.ml b/testsuite/tests/misc/takc.ml
index 8fec8984..dbb17e2a 100644
--- a/testsuite/tests/misc/takc.ml
+++ b/testsuite/tests/misc/takc.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let rec tak x y z =
   if x > y then tak (tak (x-1) y z) (tak (y-1) z x) (tak (z-1) x y)
            else z
diff --git a/testsuite/tests/misc/taku.ml b/testsuite/tests/misc/taku.ml
index 647266c8..6a6753b3 100644
--- a/testsuite/tests/misc/taku.ml
+++ b/testsuite/tests/misc/taku.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let rec tak (x, y, z) =
   if x > y then tak(tak (x-1, y, z), tak (y-1, z, x), tak (z-1, x, y))
            else z
diff --git a/testsuite/tests/misc/weaklifetime.ml b/testsuite/tests/misc/weaklifetime.ml
index d6b23f3d..a05c1623 100644
--- a/testsuite/tests/misc/weaklifetime.ml
+++ b/testsuite/tests/misc/weaklifetime.ml
@@ -1,15 +1,3 @@
-(*************************************************************************)
-(*                                                                       *)
-(*                                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.                *)
-(*                                                                       *)
-(*************************************************************************)
-
 Random.init 12345;;
 
 let size = 1000;;
diff --git a/testsuite/tests/misc/weaklifetime2.ml b/testsuite/tests/misc/weaklifetime2.ml
index 4e18640e..59f9ef4c 100644
--- a/testsuite/tests/misc/weaklifetime2.ml
+++ b/testsuite/tests/misc/weaklifetime2.ml
@@ -1,15 +1,3 @@
-(*************************************************************************)
-(*                                                                       *)
-(*                                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
 
diff --git a/testsuite/tests/misc/weaktest.ml b/testsuite/tests/misc/weaktest.ml
index ffeabf29..a8e4b084 100644
--- a/testsuite/tests/misc/weaktest.ml
+++ b/testsuite/tests/misc/weaktest.ml
@@ -1,15 +1,3 @@
-(*************************************************************************)
-(*                                                                       *)
-(*                                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;;
@@ -38,11 +26,7 @@ let bunch =
 Random.init 314;;
 
 let random_string n =
-  let result = String.create n in
-  for i = 0 to n - 1 do
-    result.[i] <- Char.chr (32 + Random.int 95);
-  done;
-  result
+  String.init n (fun _ -> Char.chr (32 + Random.int 95))
 ;;
 
 let added = ref 0;;
diff --git a/testsuite/tests/no-alias-deps/aliases.cmo.reference b/testsuite/tests/no-alias-deps/aliases.cmo.reference
index dd190714..b236b1dc 100644
--- a/testsuite/tests/no-alias-deps/aliases.cmo.reference
+++ b/testsuite/tests/no-alias-deps/aliases.cmo.reference
@@ -8,5 +8,8 @@ Interfaces imported:
 	--------------------------------	B
 	aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa	Aliases
 	--------------------------------	A
+Required globals:
+	D
+	Pervasives
 Uses unsafe features: no
 Force link: no
diff --git a/testsuite/tests/parsetree/Makefile b/testsuite/tests/parsetree/Makefile
new file mode 100644
index 00000000..8e917a02
--- /dev/null
+++ b/testsuite/tests/parsetree/Makefile
@@ -0,0 +1,23 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+COMPFLAGS=-I $(OTOPDIR)/parsing
+MODULES=
+MAIN_MODULE=test
+LIBRARIES=../../../compilerlibs/ocamlcommon
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/parsetree/source.ml b/testsuite/tests/parsetree/source.ml
new file mode 100644
index 00000000..be2d5b9d
--- /dev/null
+++ b/testsuite/tests/parsetree/source.ml
@@ -0,0 +1,7256 @@
+[@@@foo]
+
+let (x[@foo]) : unit [@foo] = ()[@foo]
+  [@@foo]
+
+type t =
+  | Foo of (t[@foo]) [@foo]
+[@@foo]
+
+[@@@foo]
+
+
+module M = struct
+  type t = {
+    l : (t [@foo]) [@foo]
+  }
+    [@@foo]
+    [@@foo]
+
+  [@@@foo]
+end[@foo]
+[@@foo]
+
+module type S = sig
+
+  include (module type of (M[@foo]))[@foo] with type t := M.t[@foo]
+    [@@foo]
+
+  [@@@foo]
+
+end[@foo]
+[@@foo]
+
+[@@@foo]
+type 'a with_default
+  =  ?size:int       (** default [42] *)
+  -> ?resizable:bool (** default [true] *)
+  -> 'a
+
+type obj = <
+  meth1 : int -> int;
+  (** method 1 *)
+
+  meth2: unit -> float (** method 2 *);
+>
+
+type var = [
+  | `Foo (** foo *)
+  | `Bar of int * string (** bar *)
+]
+
+[%%foo let x = 1 in x]
+let [%foo 2+1] : [%foo bar.baz] = [%foo "foo"]
+
+[%%foo module M = [%bar] ]
+let [%foo let () = () ] : [%foo type t = t ] = [%foo class c = object end]
+
+[%%foo: 'a list]
+let [%foo: [`Foo] ] : [%foo: t -> t ] = [%foo: < foo : t > ]
+
+[%%foo? _ ]
+[%%foo? Some y when y > 0]
+let [%foo? (Bar x | Baz x) ] : [%foo? #bar ] = [%foo? { x }]
+
+[%%foo: module M : [%baz]]
+let [%foo: include S with type t = t ]
+  : [%foo: val x : t  val y : t]
+  = [%foo: type t = t ]
+let int_with_custom_modifier =
+  1234567890_1234567890_1234567890_1234567890_1234567890z
+let float_with_custom_modifier =
+  1234567890_1234567890_1234567890_1234567890_1234567890.z
+
+let int32     = 1234l
+let int64     = 1234L
+let nativeint = 1234n
+
+let hex_without_modifier = 0x32f
+let hex_with_modifier    = 0x32g
+
+let float_without_modifer = 1.2e3
+let float_with_modifer    = 1.2g
+let%foo x = 42
+let%foo _ = () and _ = ()
+let%foo _ = ()
+
+(* Expressions *)
+let () =
+  let%foo[@foo] x = 3
+  and[@foo] y = 4 in
+  (let module%foo[@foo] M = M in ()) ;
+  (let open%foo[@foo] M in ()) ;
+  (fun%foo[@foo] x -> ()) ;
+  (function%foo[@foo] x -> ()) ;
+  (try%foo[@foo] () with _ -> ()) ;
+  (if%foo[@foo] () then () else ()) ;
+  while%foo[@foo] () do () done ;
+  for%foo[@foo] x = () to () do () done ;
+  assert%foo[@foo] true ;
+  lazy%foo[@foo] x ;
+  object%foo[@foo] end ;
+  begin%foo[@foo] 3 end ;
+  new%foo[@foo] x ;
+
+  match%foo[@foo] () with
+  (* Pattern expressions *)
+  | lazy%foo[@foo] x -> ()
+  | exception%foo[@foo] x -> ()
+
+(* Class expressions *)
+class x =
+  fun[@foo] x ->
+  let[@foo] x = 3 in
+  object[@foo]
+    inherit[@foo] x
+    val[@foo] x = 3
+    val[@foo] virtual x : t
+    val![@foo] mutable x = 3
+    method[@foo] x = 3
+    method[@foo] virtual x : t
+    method![@foo] private x = 3
+    initializer[@foo] x
+  end
+
+(* Class type expressions *)
+class type t =
+  object[@foo]
+    inherit[@foo] t
+    val[@foo] x : t
+    val[@foo] mutable x : t
+    method[@foo] x : t
+    method[@foo] private x : t
+    constraint[@foo] t = t'
+    [@@@abc]
+    [%%id]
+    [@@@aaa]
+  end
+
+(* Type expressions *)
+type t =
+  (module%foo[@foo] M)
+
+(* Module expressions *)
+module M =
+  functor[@foo] (M : S) ->
+    (val[@foo] x)
+    (struct[@foo] end)
+
+(* Module type expression *)
+module type S =
+  functor[@foo] (M:S) ->
+    (module type of[@foo] M) ->
+    (sig[@foo] end)
+
+(* Structure items *)
+let%foo[@foo] x = 4
+and[@foo] y = x
+
+type%foo[@foo] t = int
+and[@foo] t = int
+type%foo[@foo] t += T
+
+class%foo[@foo] x = x
+class type%foo[@foo] x = x
+external%foo[@foo] x : _  = ""
+exception%foo[@foo] X
+
+module%foo[@foo] M = M
+module%foo[@foo] rec M : S = M
+and[@foo] M : S = M
+module type%foo[@foo] S = S
+
+include%foo[@foo] M
+open%foo[@foo] M
+
+(* Signature items *)
+module type S = sig
+  val%foo[@foo] x : t
+  external%foo[@foo] x : t = ""
+
+  type%foo[@foo] t = int
+  and[@foo] t' = int
+  type%foo[@foo] t += T
+
+  exception%foo[@foo] X
+
+  module%foo[@foo] M : S
+  module%foo[@foo] rec M : S
+  and[@foo] M : S
+  module%foo[@foo] M = M
+
+  module type%foo[@foo] S = S
+
+  include%foo[@foo] M
+  open%foo[@foo] M
+
+  class%foo[@foo] x : t
+  class type%foo[@foo] x = x
+
+end
+
+type t = ..;;
+type t += A;;
+
+[%extension_constructor A];;
+([%extension_constructor A] : extension_constructor);;
+
+module M = struct
+  type extension_constructor = int
+end;;
+
+open M;;
+
+([%extension_constructor A] : extension_constructor);;
+
+(* By using two types we can have a recursive constraint *)
+type 'a class_name = .. constraint 'a = < cast: 'a. 'a name -> 'a; ..>
+and 'a name =
+  Class : 'a class_name -> (< cast: 'a. 'a name -> 'a; ..> as 'a) name
+;;
+
+exception Bad_cast
+;;
+
+class type castable =
+object
+  method cast: 'a.'a name -> 'a
+end
+;;
+
+(* Lets create a castable class with a name*)
+
+class type foo_t =
+object
+  inherit castable
+  method foo: string
+end
+;;
+
+type 'a class_name += Foo: foo_t class_name
+;;
+
+class foo: foo_t =
+object(self)
+  method cast: type a. a name -> a =
+    function
+        Class Foo -> (self :> foo_t)
+      | _ -> ((raise Bad_cast) : a)
+  method foo = "foo"
+end
+;;
+
+(* Now we can create a subclass of foo *)
+
+class type bar_t =
+object
+  inherit foo
+  method bar: string
+end
+;;
+
+type 'a class_name += Bar: bar_t class_name
+;;
+
+class bar: bar_t =
+object(self)
+  inherit foo as super
+  method cast: type a. a name -> a =
+    function
+        Class Bar -> (self :> bar_t)
+      | other -> super#cast other
+  method bar = "bar"
+  [@@@id]
+  [%%id]
+end
+;;
+
+(* Now lets create a mutable list of castable objects *)
+
+let clist :castable list ref = ref []
+;;
+
+let push_castable (c: #castable) =
+  clist := (c :> castable) :: !clist
+;;
+
+let pop_castable () =
+  match !clist with
+      c :: rest ->
+        clist := rest;
+        c
+    | [] -> raise Not_found
+;;
+
+(* We can add foos and bars to this list, and retrive them *)
+
+push_castable (new foo);;
+push_castable (new bar);;
+push_castable (new foo);;
+
+let c1: castable = pop_castable ();;
+let c2: castable = pop_castable ();;
+let c3: castable = pop_castable ();;
+
+(* We can also downcast these values to foos and bars *)
+
+let f1: foo = c1#cast (Class Foo);; (* Ok *)
+let f2: foo = c2#cast (Class Foo);; (* Ok *)
+let f3: foo = c3#cast (Class Foo);; (* Ok *)
+
+let b1: bar = c1#cast (Class Bar);; (* Exception Bad_cast *)
+let b2: bar = c2#cast (Class Bar);; (* Ok *)
+let b3: bar = c3#cast (Class Bar);; (* Exception Bad_cast *)
+
+type foo = ..
+;;
+
+type foo +=
+    A
+  | B of int
+;;
+
+let is_a x =
+  match x with
+    A -> true
+  | _ -> false
+;;
+
+(* The type must be open to create extension *)
+
+type foo
+;;
+
+type foo += A of int (* Error type is not open *)
+;;
+
+(* The type parameters must match *)
+
+type 'a foo = ..
+;;
+
+type ('a, 'b) foo += A of int (* Error: type parameter mismatch *)
+;;
+
+(* In a signature the type does not have to be open *)
+
+module type S =
+sig
+  type foo
+  type foo += A of float
+end
+;;
+
+(* But it must still be extensible *)
+
+module type S =
+sig
+  type foo = A of int
+  type foo += B of float (* Error foo does not have an extensible type *)
+end
+;;
+
+(* Signatures can change the grouping of extensions *)
+
+type foo = ..
+;;
+
+module M = struct
+  type foo +=
+      A of int
+    | B of string
+
+  type foo +=
+      C of int
+    | D of float
+end
+;;
+
+module type S = sig
+  type foo +=
+      B of string
+    | C of int
+
+  type foo += D of float
+
+  type foo += A of int
+end
+;;
+
+module M_S = (M : S)
+;;
+
+(* Extensions can be GADTs *)
+
+type 'a foo = ..
+;;
+
+type _ foo +=
+    A : int -> int foo
+  | B : int foo
+;;
+
+let get_num : type a. a foo -> a -> a option = fun f i1 ->
+    match f with
+        A i2 -> Some (i1 + i2)
+     |  _ -> None
+;;
+
+(* Extensions must obey constraints *)
+
+type 'a foo = .. constraint 'a = [> `Var ]
+;;
+
+type 'a foo += A of 'a
+;;
+
+let a = A 9 (* ERROR: Constraints not met *)
+;;
+
+type 'a foo += B : int foo (* ERROR: Constraints not met *)
+;;
+
+(* Signatures can make an extension private *)
+
+type foo = ..
+;;
+
+module M = struct type foo += A of int end
+;;
+
+let a1 = M.A 10
+;;
+
+module type S = sig type foo += private A of int end
+;;
+
+module M_S = (M : S)
+;;
+
+let is_s x =
+  match x with
+    M_S.A _ -> true
+  | _ -> false
+;;
+
+let a2 = M_S.A 20 (* ERROR: Cannot create a value using a private constructor *)
+;;
+
+(* Extensions can be rebound *)
+
+type foo = ..
+;;
+
+module M = struct type foo += A1 of int end
+;;
+
+type foo += A2 = M.A1
+;;
+
+type bar = ..
+;;
+
+type bar += A3 = M.A1    (* Error: rebind wrong type *)
+;;
+
+module M = struct type foo += private B1 of int end
+;;
+
+type foo += private B2 = M.B1
+;;
+
+type foo += B3 = M.B1  (* Error: rebind private extension *)
+;;
+
+type foo += C = Unknown  (* Error: unbound extension *)
+;;
+
+(* Extensions can be rebound even if type is closed *)
+
+module M : sig type foo type foo += A1 of int end
+  = struct type foo = .. type foo += A1 of int end
+
+type M.foo += A2 = M.A1
+
+(* Rebinding handles abbreviations *)
+
+type 'a foo = ..
+;;
+
+type 'a foo1 = 'a foo = ..
+;;
+
+type 'a foo2 = 'a foo = ..
+;;
+
+type 'a foo1 +=
+    A of int
+  | B of 'a
+  | C : int foo1
+;;
+
+type 'a foo2 +=
+    D = A
+  | E = B
+  | F = C
+;;
+
+(* Extensions must obey variances *)
+
+type +'a foo = ..
+;;
+
+type 'a foo += A of (int -> 'a)
+;;
+
+type 'a foo += B of ('a -> int)
+    (* ERROR: Parameter variances are not satisfied *)
+;;
+
+type _ foo += C : ('a -> int) -> 'a foo
+    (* ERROR: Parameter variances are not satisfied *)
+;;
+
+type 'a bar = ..
+;;
+
+type +'a bar += D of (int -> 'a) (* ERROR: type variances do not match *)
+;;
+
+(* Exceptions are compatible with extensions *)
+
+module M : sig
+  type exn +=
+      Foo of int * float
+    | Bar : 'a list -> exn
+end = struct
+  exception Bar : 'a list -> exn
+  exception Foo of int * float
+end
+;;
+
+module M : sig
+  exception Bar : 'a list -> exn
+  exception Foo of int * float
+end = struct
+  type exn +=
+      Foo of int * float
+    | Bar : 'a list -> exn
+end
+;;
+
+exception Foo of int * float
+;;
+
+exception Bar : 'a list -> exn
+;;
+
+module M : sig
+  type exn +=
+      Foo of int * float
+    | Bar : 'a list -> exn
+end = struct
+  exception Bar = Bar
+  exception Foo = Foo
+end
+;;
+
+(* Test toplevel printing *)
+
+type foo = ..
+;;
+
+type foo +=
+    Foo of int * int option
+  | Bar of int option
+;;
+
+let x = Foo(3, Some 4), Bar(Some 5) (* Prints Foo and Bar successfully *)
+;;
+
+type foo += Foo of string
+;;
+
+let y = x (* Prints Bar but not Foo (which has been shadowed) *)
+;;
+
+exception Foo of int * int option
+;;
+
+exception Bar of int option
+;;
+
+let x = Foo(3, Some 4), Bar(Some 5) (* Prints Foo and Bar successfully *)
+;;
+
+type foo += Foo of string
+;;
+
+let y = x (* Prints Bar and part of Foo (which has been shadowed) *)
+;;
+
+(* Test Obj functions *)
+
+type foo = ..
+;;
+
+type foo +=
+    Foo
+  | Bar of int
+;;
+
+let extension_name e = Obj.extension_name (Obj.extension_constructor e);;
+let extension_id e = Obj.extension_id (Obj.extension_constructor e);;
+
+let n1 = extension_name Foo
+;;
+
+let n2 = extension_name (Bar 1)
+;;
+
+let t = (extension_id (Bar 2)) = (extension_id (Bar 3)) (* true *)
+;;
+
+let f = (extension_id (Bar 2)) = (extension_id Foo) (* false *)
+;;
+
+let is_foo x = (extension_id Foo) = (extension_id x)
+
+type foo += Foo
+;;
+
+let f = is_foo Foo
+;;
+
+let _ = Obj.extension_constructor 7 (* Invald_arg *)
+;;
+
+let _ = Obj.extension_constructor (object method m = 3 end) (* Invald_arg *)
+;;
+(* Typed names *)
+
+module Msg : sig
+
+  type 'a tag
+
+  type result = Result : 'a tag * 'a -> result
+
+  val write : 'a tag -> 'a -> unit
+
+  val read : unit -> result
+
+  type 'a tag += Int : int tag
+
+  module type Desc = sig
+    type t
+    val label : string
+    val write : t -> string
+    val read : string -> t
+  end
+
+  module Define (D : Desc) : sig
+    type 'a tag += C : D.t tag
+  end
+
+end = struct
+
+  type 'a tag = ..
+
+  type ktag = T : 'a tag -> ktag
+
+  type 'a kind =
+  { tag : 'a tag;
+    label : string;
+    write : 'a -> string;
+    read : string -> 'a; }
+
+  type rkind = K : 'a kind -> rkind
+
+  type wkind = { f : 'a . 'a tag -> 'a kind }
+
+  let readTbl : (string, rkind) Hashtbl.t = Hashtbl.create 13
+
+  let writeTbl : (ktag, wkind) Hashtbl.t = Hashtbl.create 13
+
+  let read_raw () : string * string = raise (Failure "Not implemented")
+
+  type result = Result : 'a tag * 'a -> result
+
+  let read () =
+    let label, content = read_raw () in
+      let K k = Hashtbl.find readTbl label in
+        let body = k.read content in
+          Result(k.tag, body)
+
+  let write_raw (label : string) (content : string) =
+    raise (Failure "Not implemented")
+
+  let write (tag : 'a tag) (body : 'a) =
+    let {f} = Hashtbl.find writeTbl (T tag) in
+    let k = f tag in
+    let content = k.write body in
+      write_raw k.label content
+
+  (* Add int kind *)
+
+  type 'a tag += Int : int tag
+
+  let ik =
+    { tag = Int;
+      label = "int";
+      write = string_of_int;
+      read = int_of_string }
+
+  let () = Hashtbl.add readTbl "int" (K ik)
+
+  let () =
+    let f (type t) (i : t tag) : t kind =
+      match i with
+        Int -> ik
+      | _ -> assert false
+    in
+      Hashtbl.add writeTbl (T Int) {f}
+
+  (* Support user defined kinds *)
+
+  module type Desc = sig
+    type t
+    val label : string
+    val write : t -> string
+    val read : string -> t
+  end
+
+  module Define (D : Desc) = struct
+    type 'a tag += C : D.t tag
+    let k =
+      { tag = C;
+        label = D.label;
+        write = D.write;
+        read = D.read }
+    let () = Hashtbl.add readTbl D.label (K k)
+    let () =
+      let f (type t) (c : t tag) : t kind =
+        match c with
+          C -> k
+        | _ -> assert false
+      in
+        Hashtbl.add writeTbl (T C) {f}
+  end
+
+end;;
+
+let write_int i = Msg.write Msg.Int i;;
+
+module StrM = Msg.Define(struct
+  type t = string
+  let label = "string"
+  let read s = s
+  let write s = s
+end);;
+
+type 'a Msg.tag += String = StrM.C;;
+
+let write_string s = Msg.write String s;;
+
+let read_one () =
+  let Msg.Result(tag, body) = Msg.read () in
+  match tag with
+    Msg.Int -> print_int body
+  | String -> print_string body
+  | _ -> print_string "Unknown";;
+(* Example of algorithm parametrized with modules *)
+
+let sort (type s) set l =
+  let module Set = (val set : Set.S with type elt = s) in
+  Set.elements (List.fold_right Set.add l Set.empty)
+
+let make_set (type s) cmp =
+  let module S = Set.Make(struct
+    type t = s
+    let compare = cmp
+  end) in
+  (module S : Set.S with type elt = s)
+
+let both l =
+  List.map
+    (fun set -> sort set l)
+    [ make_set compare; make_set (fun x y -> compare y x) ]
+
+let () =
+  print_endline (String.concat "  " (List.map (String.concat "/")
+                                              (both ["abc";"xyz";"def"])))
+
+
+(* Hiding the internal representation *)
+
+module type S = sig
+  type t
+  val to_string: t -> string
+  val apply: t -> t
+  val x: t
+end
+
+let create (type s) to_string apply x =
+  let module M = struct
+    type t = s
+    let to_string = to_string
+    let apply = apply
+    let x = x
+  end in
+  (module M : S with type t = s)
+
+let forget (type s) x =
+  let module M = (val x : S with type t = s) in
+  (module M : S)
+
+let print x =
+  let module M = (val x : S) in
+  print_endline (M.to_string M.x)
+
+let apply x =
+  let module M = (val x : S) in
+  let module N = struct
+    include M
+    let x = apply x
+  end in
+  (module N : S)
+
+let () =
+  let int = forget (create string_of_int succ 0) in
+  let str = forget (create (fun s -> s) (fun s -> s ^ s) "X") in
+  List.iter print (List.map apply [int; apply int; apply (apply str)])
+
+
+(* Existential types + type equality witnesses -> pseudo GADT *)
+
+module TypEq : sig
+  type ('a, 'b) t
+  val apply: ('a, 'b) t -> 'a -> 'b
+  val refl: ('a, 'a) t
+  val sym: ('a, 'b) t -> ('b, 'a) t
+end = struct
+  type ('a, 'b) t = unit
+  let apply _ = Obj.magic
+  let refl = ()
+  let sym () = ()
+end
+
+
+module rec Typ : sig
+  module type PAIR = sig
+    type t
+    type t1
+    type t2
+    val eq: (t, t1 * t2) TypEq.t
+    val t1: t1 Typ.typ
+    val t2: t2 Typ.typ
+  end
+
+  type 'a typ =
+    | Int of ('a, int) TypEq.t
+    | String of ('a, string) TypEq.t
+    | Pair of (module PAIR with type t = 'a)
+end = struct
+  module type PAIR = sig
+    type t
+    type t1
+    type t2
+    val eq: (t, t1 * t2) TypEq.t
+    val t1: t1 Typ.typ
+    val t2: t2 Typ.typ
+  end
+
+  type 'a typ =
+    | Int of ('a, int) TypEq.t
+    | String of ('a, string) TypEq.t
+    | Pair of (module PAIR with type t = 'a)
+end
+
+open Typ
+
+let int = Int TypEq.refl
+
+let str = String TypEq.refl
+
+let pair (type s1) (type s2) t1 t2 =
+  let module P = struct
+    type t = s1 * s2
+    type t1 = s1
+    type t2 = s2
+    let eq = TypEq.refl
+    let t1 = t1
+    let t2 = t2
+  end in
+  let pair = (module P : PAIR with type t = s1 * s2) in
+  Pair pair
+
+module rec Print : sig
+  val to_string: 'a Typ.typ -> 'a -> string
+end = struct
+  let to_string (type s) t x =
+    match t with
+    | Int eq -> string_of_int (TypEq.apply eq x)
+    | String eq -> Printf.sprintf "%S" (TypEq.apply eq x)
+    | Pair p ->
+        let module P = (val p : PAIR with type t = s) in
+        let (x1, x2) = TypEq.apply P.eq x in
+        Printf.sprintf "(%s,%s)" (Print.to_string P.t1 x1)
+                       (Print.to_string P.t2 x2)
+end
+
+let () =
+  print_endline (Print.to_string int 10);
+  print_endline (Print.to_string (pair int (pair str int)) (123, ("A", 456)))
+
+
+(* #6262: first-class modules and module type aliases *)
+
+module type S1 = sig end
+module type S2 = S1
+
+let _f (x : (module S1)) : (module S2) = x
+
+module X = struct
+  module type S
+end
+module Y = struct include X end
+
+let _f (x : (module X.S)) : (module Y.S) = x
+
+(* PR#6194, main example *)
+module type S3 = sig val x : bool end;;
+let f = function
+  | Some (module M : S3) when M.x ->1
+  | Some _ [@foooo]-> 2
+  | None -> 3
+;;
+print_endline (string_of_int (f (Some (module struct let x = false end))));;
+type 'a ty =
+  | Int : int ty
+  | Bool : bool ty
+
+let fbool (type t) (x : t) (tag : t ty) =
+  match tag with
+  | Bool -> x
+;;
+(* val fbool : 'a -> 'a ty -> 'a =  *)
+(** OK: the return value is x of type t **)
+
+let fint (type t) (x : t) (tag : t ty) =
+  match tag with
+  | Int -> x > 0
+;;
+(* val fint : 'a -> 'a ty -> bool =  *)
+(** OK: the return value is x > 0 of type bool;
+This has used the equation t = bool, not visible in the return type **)
+
+let f (type t) (x : t) (tag : t ty) =
+  match tag with
+  | Int -> x > 0
+  | Bool -> x
+(* val f : 'a -> 'a ty -> bool =  *)
+
+
+let g (type t) (x : t) (tag : t ty) =
+  match tag with
+  | Bool -> x
+  | Int -> x > 0
+(* Error: This expression has type bool but an expression was expected of type
+t = int *)
+
+let id x = x;;
+let idb1 = (fun id -> let _ = id true in id) id;;
+let idb2 : bool -> bool = id;;
+let idb3 ( _ : bool ) = false;;
+
+let g (type t) (x : t) (tag : t ty) =
+  match tag with
+  | Bool -> idb3 x
+  | Int -> x > 0
+
+let g (type t) (x : t) (tag : t ty) =
+  match tag with
+  | Bool -> idb2 x
+  | Int -> x > 0
+(* Encoding generics using GADTs *)
+(* (c) Alain Frisch / Lexifi *)
+(* cf. http://www.lexifi.com/blog/dynamic-types *)
+
+(* Basic tag *)
+
+type 'a ty =
+  | Int: int ty
+  | String: string ty
+  | List: 'a ty -> 'a list ty
+  | Pair: ('a ty * 'b ty) -> ('a * 'b) ty
+;;
+
+(* Tagging data *)
+
+type variant =
+  | VInt of int
+  | VString of string
+  | VList of variant list
+  | VPair of variant * variant
+
+let rec variantize: type t. t ty -> t -> variant =
+  fun ty x ->
+    (* type t is abstract here *)
+    match ty with
+    | Int -> VInt x  (* in this branch: t = int *)
+    | String -> VString x (* t = string *)
+    | List ty1 ->
+        VList (List.map (variantize ty1) x)
+        (* t = 'a list for some 'a *)
+    | Pair (ty1, ty2) ->
+        VPair (variantize ty1 (fst x), variantize ty2 (snd x))
+        (* t = ('a, 'b) for some 'a and 'b *)
+
+exception VariantMismatch
+
+let rec devariantize: type t. t ty -> variant -> t =
+  fun ty v ->
+    match ty, v with
+    | Int, VInt x -> x
+    | String, VString x -> x
+    | List ty1, VList vl ->
+        List.map (devariantize ty1) vl
+    | Pair (ty1, ty2), VPair (x1, x2) ->
+        (devariantize ty1 x1, devariantize ty2 x2)
+    | _ -> raise VariantMismatch
+;;
+
+(* Handling records *)
+
+type 'a ty =
+  | Int: int ty
+  | String: string ty
+  | List: 'a ty -> 'a list ty
+  | Pair: ('a ty * 'b ty) -> ('a * 'b) ty
+  | Record: 'a record -> 'a ty
+
+and 'a record =
+    {
+     path: string;
+     fields: 'a field_ list;
+    }
+
+and 'a field_ =
+  | Field: ('a, 'b) field -> 'a field_
+
+and ('a, 'b) field =
+    {
+     label: string;
+     field_type: 'b ty;
+     get: ('a -> 'b);
+    }
+;;
+
+(* Again *)
+
+type variant =
+  | VInt of int
+  | VString of string
+  | VList of variant list
+  | VPair of variant * variant
+  | VRecord of (string * variant) list
+
+let rec variantize: type t. t ty -> t -> variant =
+  fun ty x ->
+    (* type t is abstract here *)
+    match ty with
+    | Int -> VInt x  (* in this branch: t = int *)
+    | String -> VString x (* t = string *)
+    | List ty1 ->
+        VList (List.map (variantize ty1) x)
+        (* t = 'a list for some 'a *)
+    | Pair (ty1, ty2) ->
+        VPair (variantize ty1 (fst x), variantize ty2 (snd x))
+        (* t = ('a, 'b) for some 'a and 'b *)
+    | Record {fields} ->
+        VRecord
+          (List.map (fun (Field{field_type; label; get}) ->
+                       (label, variantize field_type (get x))) fields)
+;;
+
+(* Extraction *)
+
+type 'a ty =
+  | Int: int ty
+  | String: string ty
+  | List: 'a ty -> 'a list ty
+  | Pair: ('a ty * 'b ty) -> ('a * 'b) ty
+  | Record: ('a, 'builder) record -> 'a ty
+
+and ('a, 'builder) record =
+    {
+     path: string;
+     fields: ('a, 'builder) field list;
+     create_builder: (unit -> 'builder);
+     of_builder: ('builder -> 'a);
+    }
+
+and ('a, 'builder) field =
+  | Field: ('a, 'builder, 'b) field_ -> ('a, 'builder) field
+
+and ('a, 'builder, 'b) field_ =
+  {
+   label: string;
+   field_type: 'b ty;
+   get: ('a -> 'b);
+   set: ('builder -> 'b -> unit);
+  }
+
+let rec devariantize: type t. t ty -> variant -> t =
+  fun ty v ->
+    match ty, v with
+    | Int, VInt x -> x
+    | String, VString x -> x
+    | List ty1, VList vl ->
+        List.map (devariantize ty1) vl
+    | Pair (ty1, ty2), VPair (x1, x2) ->
+        (devariantize ty1 x1, devariantize ty2 x2)
+    | Record {fields; create_builder; of_builder}, VRecord fl ->
+        if List.length fields <> List.length fl then raise VariantMismatch;
+        let builder = create_builder () in
+        List.iter2
+          (fun (Field {label; field_type; set}) (lab, v) ->
+            if label <> lab then raise VariantMismatch;
+            set builder (devariantize field_type v)
+          )
+          fields fl;
+        of_builder builder
+    | _ -> raise VariantMismatch
+;;
+
+type my_record  =
+    {
+     a: int;
+     b: string list;
+    }
+
+let my_record =
+  let fields =
+    [
+     Field {label = "a"; field_type = Int;
+            get = (fun {a} -> a);
+            set = (fun (r, _) x -> r := Some x)};
+     Field {label = "b"; field_type = List String;
+            get = (fun {b} -> b);
+            set = (fun (_, r) x -> r := Some x)};
+    ]
+  in
+  let create_builder () = (ref None, ref None) in
+  let of_builder (a, b) =
+    match !a, !b with
+    | Some a, Some b -> {a; b}
+    | _ -> failwith "Some fields are missing in record of type my_record"
+  in
+  Record {path = "My_module.my_record"; fields; create_builder; of_builder}
+;;
+
+(* Extension to recursive types and polymorphic variants *)
+(* by Jacques Garrigue *)
+
+type noarg = Noarg
+
+type (_,_) ty =
+  | Int: (int,_) ty
+  | String: (string,_) ty
+  | List: ('a,'e) ty -> ('a list, 'e) ty
+  | Option: ('a,'e) ty -> ('a option, 'e) ty
+  | Pair: (('a,'e) ty * ('b,'e) ty) -> ('a * 'b,'e) ty
+  (* Support for type variables and recursive types *)
+  | Var: ('a, 'a -> 'e) ty
+  | Rec: ('a, 'a -> 'e) ty -> ('a,'e) ty
+  | Pop: ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  (* Change the representation of a type *)
+  | Conv: string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  (* Sum types (both normal sums and polymorphic variants) *)
+  | Sum: ('a, 'e, 'b) ty_sum -> ('a, 'e) ty
+
+and ('a, 'e, 'b) ty_sum =
+    { sum_proj: 'a -> string * 'e ty_dyn option;
+      sum_cases: (string * ('e,'b) ty_case) list;
+      sum_inj: 'c. ('b,'c) ty_sel * 'c -> 'a; }
+
+and 'e ty_dyn =              (* dynamic type *)
+  | Tdyn : ('a,'e) ty * 'a -> 'e ty_dyn
+
+and (_,_) ty_sel =           (* selector from a list of types *)
+  | Thd : ('a -> 'b, 'a) ty_sel
+  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
+
+and (_,_) ty_case =          (* type a sum case *)
+  | TCarg : ('b,'a) ty_sel * ('a,'e) ty -> ('e,'b) ty_case
+  | TCnoarg : ('b,noarg) ty_sel -> ('e,'b) ty_case
+;;
+
+type _ ty_env =              (* type variable substitution *)
+  | Enil : unit ty_env
+  | Econs : ('a,'e) ty * 'e ty_env -> ('a -> 'e) ty_env
+;;
+
+(* Comparing selectors *)
+type (_,_) eq = Eq: ('a,'a) eq
+
+let rec eq_sel : type a b c. (a,b) ty_sel -> (a,c) ty_sel -> (b,c) eq option =
+  fun s1 s2 ->
+    match s1, s2 with
+    | Thd, Thd -> Some Eq
+    | Ttl s1, Ttl s2 ->
+        (match eq_sel s1 s2 with None -> None | Some Eq -> Some Eq)
+    | _ -> None
+
+(* Auxiliary function to get the type of a case from its selector *)
+let rec get_case : type a b e.
+  (b, a) ty_sel -> (string * (e,b) ty_case) list -> string * (a, e) ty option =
+  fun sel cases ->
+  match cases with
+  | (name, TCnoarg sel') :: rem ->
+      begin match eq_sel sel sel' with
+      | None -> get_case sel rem
+      | Some Eq -> name, None
+      end
+  | (name, TCarg (sel', ty)) :: rem ->
+      begin match eq_sel sel sel' with
+      | None -> get_case sel rem
+      | Some Eq -> name, Some ty
+      end
+  | [] -> raise Not_found
+;;
+
+(* Untyped representation of values *)
+type variant =
+  | VInt of int
+  | VString of string
+  | VList of variant list
+  | VOption of variant option
+  | VPair of variant * variant
+  | VConv of string * variant
+  | VSum of string * variant option
+
+let may_map f = function Some x -> Some (f x) | None -> None
+
+let rec variantize : type a e. e ty_env -> (a,e) ty -> a -> variant =
+  fun e ty v ->
+  match ty with
+  | Int -> VInt v
+  | String -> VString v
+  | List t -> VList (List.map (variantize e t) v)
+  | Option t -> VOption (may_map (variantize e t) v)
+  | Pair (t1, t2) -> VPair (variantize e t1 (fst v), variantize e t2 (snd v))
+  | Rec t -> variantize (Econs (ty, e)) t v
+  | Pop t -> (match e with Econs (_, e') -> variantize e' t v)
+  | Var -> (match e with Econs (t, e') -> variantize e' t v)
+  | Conv (s, proj, inj, t) -> VConv (s, variantize e t (proj v))
+  | Sum ops ->
+      let tag, arg = ops.sum_proj v in
+      VSum (tag, may_map (function Tdyn (ty,arg) -> variantize e ty arg) arg)
+;;
+
+let rec devariantize : type t e. e ty_env -> (t, e) ty -> variant -> t =
+  fun e ty v ->
+  match ty, v with
+  | Int, VInt x -> x
+  | String, VString x -> x
+  | List ty1, VList vl ->
+      List.map (devariantize e ty1) vl
+  | Pair (ty1, ty2), VPair (x1, x2) ->
+      (devariantize e ty1 x1, devariantize e ty2 x2)
+  | Rec t, _ -> devariantize (Econs (ty, e)) t v
+  | Pop t, _ -> (match e with Econs (_, e') -> devariantize e' t v)
+  | Var, _ -> (match e with Econs (t, e') -> devariantize e' t v)
+  | Conv (s, proj, inj, t), VConv (s', v) when s = s' ->
+      inj (devariantize e t v)
+  | Sum ops, VSum (tag, a) ->
+      begin try match List.assoc tag ops.sum_cases, a with
+      | TCarg (sel, t), Some a -> ops.sum_inj (sel, devariantize e t a)
+      | TCnoarg sel, None -> ops.sum_inj (sel, Noarg)
+      | _ -> raise VariantMismatch
+      with Not_found -> raise VariantMismatch
+      end
+  | _ -> raise VariantMismatch
+;;
+
+(* First attempt: represent 1-constructor variants using Conv *)
+let wrap_A t = Conv ("`A", (fun (`A x) -> x), (fun x -> `A x), t);;
+
+let ty a = Rec (wrap_A (Option (Pair (a, Var)))) ;;
+let v = variantize Enil (ty Int);;
+let x = v (`A (Some (1, `A (Some (2, `A None))))) ;;
+
+(* Can also use it to decompose a tuple *)
+
+let triple t1 t2 t3 =
+  Conv ("Triple", (fun (a,b,c) -> (a,(b,c))),
+        (fun (a,(b,c)) -> (a,b,c)), Pair (t1, Pair (t2, t3)))
+
+let v = variantize Enil (triple String Int Int) ("A", 2, 3) ;;
+
+(* Second attempt: introduce a real sum construct *)
+let ty_abc =
+  (* Could also use [get_case] for proj, but direct definition is shorter *)
+  let proj = function
+      `A n -> "A", Some (Tdyn (Int, n))
+    | `B s -> "B", Some (Tdyn (String, s))
+    | `C   -> "C", None
+  (* Define inj in advance to be able to write the type annotation easily *)
+  and inj : type c. (int -> string -> noarg -> unit, c) ty_sel * c ->
+    [`A of int | `B of string | `C] = function
+        Thd, v -> `A v
+      | Ttl Thd, v -> `B v
+      | Ttl (Ttl Thd), Noarg -> `C
+  in
+  (* Coherence of sum_inj and sum_cases is checked by the typing *)
+  Sum { sum_proj = proj; sum_inj = inj; sum_cases =
+        [ "A", TCarg (Thd, Int); "B", TCarg (Ttl Thd, String);
+          "C", TCnoarg (Ttl (Ttl Thd)) ] }
+;;
+
+let v = variantize Enil ty_abc (`A 3)
+let a = devariantize Enil ty_abc v
+
+(* And an example with recursion... *)
+type 'a vlist = [`Nil | `Cons of 'a * 'a vlist]
+
+let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t ->
+  let tcons = Pair (Pop t, Var) in
+  Rec (Sum {
+       sum_proj = (function
+           `Nil -> "Nil", None
+         | `Cons p -> "Cons", Some (Tdyn (tcons, p)));
+       sum_cases = ["Nil", TCnoarg Thd; "Cons", TCarg (Ttl Thd, tcons)];
+       sum_inj = fun (type c) ->
+         (function
+         | Thd, Noarg -> `Nil
+         | Ttl Thd, v -> `Cons v
+         : (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist)
+         (* One can also write the type annotation directly *)
+     })
+
+let v = variantize Enil (ty_list Int) (`Cons (1, `Cons (2, `Nil))) ;;
+
+
+(* Simpler but weaker approach *)
+
+type (_,_) ty =
+  | Int: (int,_) ty
+  | String: (string,_) ty
+  | List: ('a,'e) ty -> ('a list, 'e) ty
+  | Option: ('a,'e) ty -> ('a option, 'e) ty
+  | Pair: (('a,'e) ty * ('b,'e) ty) -> ('a * 'b,'e) ty
+  | Var: ('a, 'a -> 'e) ty
+  | Rec: ('a, 'a -> 'e) ty -> ('a,'e) ty
+  | Pop: ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv: string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum: ('a -> string * 'e ty_dyn option) * (string * 'e ty_dyn option -> 'a)
+             -> ('a, 'e) ty
+and 'e ty_dyn =
+  | Tdyn : ('a,'e) ty * 'a -> 'e ty_dyn
+
+let ty_abc : ([`A of int | `B of string | `C],'e) ty =
+  (* Could also use [get_case] for proj, but direct definition is shorter *)
+  Sum (
+  (function
+      `A n -> "A", Some (Tdyn (Int, n))
+    | `B s -> "B", Some (Tdyn (String, s))
+    | `C   -> "C", None),
+  (function
+      "A", Some (Tdyn (Int, n)) -> `A n
+    | "B", Some (Tdyn (String, s)) -> `B s
+    | "C", None -> `C
+    | _ -> invalid_arg "ty_abc"))
+;;
+
+(* Breaks: no way to pattern-match on a full recursive type *)
+let ty_list : type a e. (a,e) ty -> (a vlist,e) ty = fun t ->
+  let targ = Pair (Pop t, Var) in
+  Rec (Sum (
+  (function `Nil -> "Nil", None
+    | `Cons p -> "Cons", Some (Tdyn (targ, p))),
+  (function "Nil", None -> `Nil
+    | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p)))
+;;
+
+(* Define Sum using object instead of record for first-class polymorphism *)
+
+type (_,_) ty =
+  | Int: (int,_) ty
+  | String: (string,_) ty
+  | List: ('a,'e) ty -> ('a list, 'e) ty
+  | Option: ('a,'e) ty -> ('a option, 'e) ty
+  | Pair: (('a,'e) ty * ('b,'e) ty) -> ('a * 'b,'e) ty
+  | Var: ('a, 'a -> 'e) ty
+  | Rec: ('a, 'a -> 'e) ty -> ('a,'e) ty
+  | Pop: ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv: string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum: < proj: 'a -> string * 'e ty_dyn option;
+           cases: (string * ('e,'b) ty_case) list;
+           inj: 'c. ('b,'c) ty_sel * 'c -> 'a >
+          -> ('a, 'e) ty
+
+and 'e ty_dyn =
+  | Tdyn : ('a,'e) ty * 'a -> 'e ty_dyn
+
+and (_,_) ty_sel =
+  | Thd : ('a -> 'b, 'a) ty_sel
+  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
+
+and (_,_) ty_case =
+  | TCarg : ('b,'a) ty_sel * ('a,'e) ty -> ('e,'b) ty_case
+  | TCnoarg : ('b,noarg) ty_sel -> ('e,'b) ty_case
+;;
+
+let ty_abc : ([`A of int | `B of string | `C] as 'a, 'e) ty =
+  Sum (object
+    method proj = function
+        `A n -> "A", Some (Tdyn (Int, n))
+      | `B s -> "B", Some (Tdyn (String, s))
+      | `C -> "C", None
+    method cases =
+      [ "A", TCarg (Thd, Int); "B", TCarg (Ttl Thd, String);
+        "C", TCnoarg (Ttl (Ttl Thd)) ];
+    method inj : type c.
+        (int -> string -> noarg -> unit, c) ty_sel * c ->
+          [`A of int | `B of string | `C] =
+      function
+        Thd, v -> `A v
+      | Ttl Thd, v -> `B v
+      | Ttl (Ttl Thd), Noarg -> `C
+  end)
+
+type 'a vlist = [`Nil | `Cons of 'a * 'a vlist]
+
+let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t ->
+  let tcons = Pair (Pop t, Var) in
+  Rec (Sum (object
+    method proj = function
+        `Nil -> "Nil", None
+      | `Cons p -> "Cons", Some (Tdyn (tcons, p))
+    method cases = ["Nil", TCnoarg Thd; "Cons", TCarg (Ttl Thd, tcons)]
+    method inj : type c.(noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist
+    = function
+      | Thd, Noarg -> `Nil
+      | Ttl Thd, v -> `Cons v
+  end))
+;;
+
+(*
+type (_,_) ty_assoc =
+  | Anil : (unit,'e) ty_assoc
+  | Acons : string * ('a,'e) ty * ('b,'e) ty_assoc -> ('a -> 'b, 'e) ty_assoc
+
+and (_,_) ty_pvar =
+  | Pnil : ('a,'e) ty_pvar
+  | Pconst : 't * ('b,'e) ty_pvar -> ('t -> 'b, 'e) ty_pvar
+  | Parg : 't * ('a,'e) ty * ('b,'e) ty_pvar -> ('t * 'a -> 'b, 'e) ty_pvar
+*)
+(*
+   An attempt at encoding omega examples from the 2nd Central European
+   Functional Programming School:
+     Generic Programming in Omega, by Tim Sheard and Nathan Linger
+          http://web.cecs.pdx.edu/~sheard/
+*)
+
+(* Basic types *)
+
+type ('a,'b) sum = Inl of 'a | Inr of 'b
+
+type zero = Zero
+type 'a succ = Succ of 'a
+type _ nat =
+  | NZ : zero nat
+  | NS : 'a nat -> 'a succ nat
+;;
+
+(* 2: A simple example *)
+
+type (_,_) seq =
+  | Snil  : ('a,zero) seq
+  | Scons : 'a * ('a,'n) seq -> ('a, 'n succ) seq
+;;
+
+let l1 = Scons (3, Scons (5, Snil)) ;;
+
+(* We do not have type level functions, so we need to use witnesses. *)
+(* We copy here the definitions from section 3.9 *)
+(* Note the addition of the ['a nat] argument to PlusZ, since we do not
+   have kinds *)
+type (_,_,_) plus =
+  | PlusZ : 'a nat -> (zero, 'a, 'a) plus
+  | PlusS : ('a,'b,'c) plus -> ('a succ, 'b, 'c succ) plus
+;;
+
+let rec length : type a n. (a,n) seq -> n nat = function
+  | Snil -> NZ
+  | Scons (_, s) -> NS (length s)
+;;
+
+(* app returns the catenated lists with a witness proving that
+   the size is the sum of its two inputs *)
+type (_,_,_) app = App : ('a,'p) seq * ('n,'m,'p) plus -> ('a,'n,'m) app
+
+let rec app : type a n m. (a,n) seq -> (a,m) seq -> (a,n,m) app =
+  fun xs ys ->
+  match xs with
+  | Snil -> App (ys, PlusZ (length ys))
+  | Scons (x, xs') ->
+      let App (xs'', pl) = app xs' ys in
+      App (Scons (x, xs''), PlusS pl)
+;;
+
+(* 3.1 Feature: kinds *)
+
+(* We do not have kinds, but we can encode them as predicates *)
+
+type tp = TP
+type nd = ND
+type ('a,'b) fk = FK
+type _ shape =
+  | Tp : tp shape
+  | Nd : nd shape
+  | Fk : 'a shape * 'b shape -> ('a,'b) fk shape
+;;
+type tt = TT
+type ff = FF
+type _ boolean =
+  | BT : tt boolean
+  | BF : ff boolean
+;;
+
+(* 3.3 Feature : GADTs *)
+
+type (_,_) path =
+  | Pnone : 'a -> (tp,'a) path
+  | Phere : (nd,'a) path
+  | Pleft : ('x,'a) path -> (('x,'y) fk, 'a) path
+  | Pright : ('y,'a) path -> (('x,'y) fk, 'a) path
+;;
+type (_,_) tree =
+  | Ttip  : (tp,'a) tree
+  | Tnode : 'a -> (nd,'a) tree
+  | Tfork : ('x,'a) tree * ('y,'a) tree -> (('x,'y)fk, 'a) tree
+;;
+let tree1 = Tfork (Tfork (Ttip, Tnode 4), Tfork (Tnode 4, Tnode 3))
+;;
+let rec find : type sh.
+    ('a -> 'a -> bool) -> 'a -> (sh,'a) tree -> (sh,'a) path list
+  = fun eq n t ->
+    match t with
+    | Ttip -> []
+    | Tnode m ->
+        if eq n m then [Phere] else []
+    | Tfork (x, y) ->
+        List.map (fun x -> Pleft x) (find eq n x) @
+        List.map (fun x -> Pright x) (find eq n y)
+;;
+let rec extract : type sh. (sh,'a) path -> (sh,'a) tree -> 'a = fun p t ->
+  match (p, t) with
+  | Pnone x, Ttip -> x
+  | Phere, Tnode y -> y
+  | Pleft p, Tfork(l,_) -> extract p l
+  | Pright p, Tfork(_,r) -> extract p r
+;;
+
+(* 3.4 Pattern : Witness *)
+
+type (_,_) le =
+  | LeZ : 'a nat -> (zero, 'a) le
+  | LeS : ('n, 'm) le -> ('n succ, 'm succ) le
+;;
+type _ even =
+  | EvenZ : zero even
+  | EvenSS : 'n even -> 'n succ succ even
+;;
+type one = zero succ
+type two = one succ
+type three = two succ
+type four = three succ
+;;
+let even0 : zero even = EvenZ
+let even2 : two even = EvenSS EvenZ
+let even4 : four even = EvenSS (EvenSS EvenZ)
+;;
+let p1 : (two, one, three) plus = PlusS (PlusS (PlusZ (NS NZ)))
+;;
+let rec summandLessThanSum : type a b c. (a,b,c) plus -> (a,c) le = fun p ->
+  match p with
+  | PlusZ n -> LeZ n
+  | PlusS p' -> LeS (summandLessThanSum p')
+;;
+
+(* 3.8 Pattern: Leibniz Equality *)
+
+type (_,_) equal = Eq : ('a,'a) equal
+
+let convert : type a b. (a,b) equal -> a -> b = fun Eq x -> x
+
+let rec sameNat : type a b. a nat -> b nat -> (a,b) equal option = fun a b ->
+  match a, b with
+  | NZ, NZ -> Some Eq
+  | NS a', NS b' ->
+      begin match sameNat a' b' with
+      | Some Eq -> Some Eq
+      | None -> None
+      end
+  | _ -> None
+;;
+
+(* Extra: associativity of addition *)
+
+let rec plus_func : type a b m n.
+  (a,b,m) plus -> (a,b,n) plus -> (m,n) equal =
+  fun p1 p2 ->
+  match p1, p2 with
+  | PlusZ _, PlusZ _ -> Eq
+  | PlusS p1', PlusS p2' ->
+      let Eq = plus_func p1' p2' in Eq
+
+let rec plus_assoc : type a b c ab bc m n.
+  (a,b,ab) plus -> (ab,c,m) plus ->
+  (b,c,bc) plus -> (a,bc,n) plus -> (m,n) equal = fun p1 p2 p3 p4 ->
+  match p1, p4 with
+  | PlusZ b, PlusZ bc ->
+      let Eq = plus_func p2 p3 in Eq
+  | PlusS p1', PlusS p4' ->
+      let PlusS p2' = p2 in
+      let Eq = plus_assoc p1' p2' p3 p4' in Eq
+;;
+
+(* 3.9 Computing Programs and Properties Simultaneously *)
+
+(* Plus and app1 are moved to section 2 *)
+
+let smaller : type a b. (a succ, b succ) le -> (a,b) le =
+  function LeS x -> x ;;
+
+type (_,_) diff = Diff : 'c nat * ('a,'c,'b) plus -> ('a,'b) diff ;;
+
+(*
+let rec diff : type a b. (a,b) le -> a nat -> b nat -> (a,b) diff =
+  fun le a b ->
+  match a, b, le with
+  | NZ, m, _ -> Diff (m, PlusZ m)
+  | NS x, NZ, _ -> assert false
+  | NS x, NS y, q ->
+      match diff (smaller q) x y with Diff (m, p) -> Diff (m, PlusS p)
+;;
+*)
+
+let rec diff : type a b. (a,b) le -> a nat -> b nat -> (a,b) diff =
+  fun le a b ->
+  match le, a, b with
+  | LeZ _, _, m -> Diff (m, PlusZ m)
+  | LeS q, NS x, NS y ->
+      match diff q x y with Diff (m, p) -> Diff (m, PlusS p)
+;;
+
+let rec diff : type a b. (a,b) le -> a nat -> b nat -> (a,b) diff =
+  fun le a b ->
+  match a, b,le with (* warning *)
+  | NZ, m, LeZ _ -> Diff (m, PlusZ m)
+  | NS x, NS y, LeS q ->
+      (match diff q x y with Diff (m, p) -> Diff (m, PlusS p))
+  | _ -> .
+;;
+
+let rec diff : type a b. (a,b) le -> b nat -> (a,b) diff =
+  fun le b ->
+  match b,le with
+  | m, LeZ _ -> Diff (m, PlusZ m)
+  | NS y, LeS q ->
+      match diff q y with Diff (m, p) -> Diff (m, PlusS p)
+;;
+
+type (_,_) filter = Filter : ('m,'n) le * ('a,'m) seq -> ('a,'n) filter
+
+let rec leS' : type m n. (m,n) le -> (m,n succ) le = function
+  | LeZ n -> LeZ (NS n)
+  | LeS le -> LeS (leS' le)
+;;
+
+let rec filter : type a n. (a -> bool) -> (a,n) seq -> (a,n) filter =
+  fun f s ->
+  match s with
+  | Snil -> Filter (LeZ NZ, Snil)
+  | Scons (a,l) ->
+      match filter f l with Filter (le, l') ->
+        if f a then Filter (LeS le, Scons (a, l'))
+        else Filter (leS' le, l')
+;;
+
+(* 4.1 AVL trees *)
+
+type (_,_,_) balance =
+  | Less : ('h, 'h succ, 'h succ) balance
+  | Same : ('h, 'h, 'h) balance
+  | More : ('h succ, 'h, 'h succ) balance
+
+type _ avl =
+  | Leaf : zero avl
+  | Node :
+      ('hL, 'hR, 'hMax) balance * 'hL avl * int * 'hR avl -> 'hMax succ avl
+
+type avl' = Avl : 'h avl -> avl'
+;;
+
+let empty = Avl Leaf
+
+let rec elem : type h. int -> h avl -> bool = fun x t ->
+  match t with
+  | Leaf -> false
+  | Node (_, l, y, r) ->
+      x = y || if x < y then elem x l else elem x r
+;;
+
+let rec rotr : type n. (n succ succ) avl -> int -> n avl ->
+  ((n succ succ) avl, (n succ succ succ) avl) sum =
+  fun tL y tR ->
+  match tL with
+  | Node (Same, a, x, b) -> Inr (Node (Less, a, x, Node (More, b, y, tR)))
+  | Node (More, a, x, b) -> Inl (Node (Same, a, x, Node (Same, b, y, tR)))
+  | Node (Less, a, x, Node (Same, b, z, c)) ->
+      Inl (Node (Same, Node (Same, a, x, b), z, Node (Same, c, y, tR)))
+  | Node (Less, a, x, Node (Less, b, z, c)) ->
+      Inl (Node (Same, Node (More, a, x, b), z, Node (Same, c, y, tR)))
+  | Node (Less, a, x, Node (More, b, z, c)) ->
+      Inl (Node (Same, Node (Same, a, x, b), z, Node (Less, c, y, tR)))
+;;
+let rec rotl : type n. n avl -> int -> (n succ succ) avl ->
+  ((n succ succ) avl, (n succ succ succ) avl) sum =
+  fun tL u tR ->
+  match tR with
+  | Node (Same, a, x, b) -> Inr (Node (More, Node (Less, tL, u, a), x, b))
+  | Node (Less, a, x, b) -> Inl (Node (Same, Node (Same, tL, u, a), x, b))
+  | Node (More, Node (Same, a, x, b), y, c) ->
+      Inl (Node (Same, Node (Same, tL, u, a), x, Node (Same, b, y, c)))
+  | Node (More, Node (Less, a, x, b), y, c) ->
+      Inl (Node (Same, Node (More, tL, u, a), x, Node (Same, b, y, c)))
+  | Node (More, Node (More, a, x, b), y, c) ->
+      Inl (Node (Same, Node (Same, tL, u, a), x, Node (Less, b, y, c)))
+;;
+let rec ins : type n. int -> n avl -> (n avl, (n succ) avl) sum =
+  fun x t ->
+  match t with
+  | Leaf -> Inr (Node (Same, Leaf, x, Leaf))
+  | Node (bal, a, y, b) ->
+      if x = y then Inl t else
+      if x < y then begin
+        match ins x a with
+        | Inl a -> Inl (Node (bal, a, y, b))
+        | Inr a ->
+            match bal with
+            | Less -> Inl (Node (Same, a, y, b))
+            | Same -> Inr (Node (More, a, y, b))
+            | More -> rotr a y b
+      end else begin
+        match ins x b with
+        | Inl b -> Inl (Node (bal, a, y, b) : n avl)
+        | Inr b ->
+            match bal with
+            | More -> Inl (Node (Same, a, y, b) : n avl)
+            | Same -> Inr (Node (Less, a, y, b) : n succ avl)
+            | Less -> rotl a y b
+      end
+;;
+
+let insert x (Avl t) =
+  match ins x t with
+  | Inl t -> Avl t
+  | Inr t -> Avl t
+;;
+
+let rec del_min : type n. (n succ) avl -> int * (n avl, (n succ) avl) sum =
+  function
+  | Node (Less, Leaf, x, r) -> (x, Inl r)
+  | Node (Same, Leaf, x, r) -> (x, Inl r)
+  | Node (bal, (Node _ as l) , x, r) ->
+      match del_min l with
+      | y, Inr l -> (y, Inr (Node (bal, l, x, r)))
+      | y, Inl l ->
+          (y, match bal with
+          | Same -> Inr (Node (Less, l, x, r))
+          | More -> Inl (Node (Same, l, x, r))
+          | Less -> rotl l x r)
+
+type _ avl_del =
+  | Dsame : 'n avl -> 'n avl_del
+  | Ddecr : ('m succ, 'n) equal * 'm avl -> 'n avl_del
+
+let rec del : type n. int -> n avl -> n avl_del = fun y t ->
+  match t with
+  | Leaf -> Dsame Leaf
+  | Node (bal, l, x, r) ->
+      if x = y then begin
+        match r with
+        | Leaf ->
+            begin match bal with
+            | Same -> Ddecr (Eq, l)
+            | More -> Ddecr (Eq, l)
+            end
+        | Node _ ->
+            begin match bal, del_min r with
+            | _, (z, Inr r) -> Dsame (Node (bal, l, z, r))
+            | Same, (z, Inl r) -> Dsame (Node (More, l, z, r))
+            | Less, (z, Inl r) -> Ddecr (Eq, Node (Same, l, z, r))
+            | More, (z, Inl r) ->
+                match rotr l z r with
+                | Inl t -> Ddecr (Eq, t)
+                | Inr t -> Dsame t
+            end
+      end else if y < x then begin
+        match del y l with
+        | Dsame l -> Dsame (Node (bal, l, x, r))
+        | Ddecr(Eq,l) ->
+            begin match bal with
+            | Same -> Dsame (Node (Less, l, x, r))
+            | More -> Ddecr (Eq, Node (Same, l, x, r))
+            | Less ->
+                match rotl l x r with
+                | Inl t -> Ddecr (Eq, t)
+                | Inr t -> Dsame t
+            end
+      end else begin
+        match del y r with
+        | Dsame r -> Dsame (Node (bal, l, x, r))
+        | Ddecr(Eq,r) ->
+            begin match bal with
+            | Same -> Dsame (Node (More, l, x, r))
+            | Less -> Ddecr (Eq, Node (Same, l, x, r))
+            | More ->
+                match rotr l x r with
+                | Inl t -> Ddecr (Eq, t)
+                | Inr t -> Dsame t
+            end
+      end
+;;
+
+let delete x (Avl t) =
+  match del x t with
+  | Dsame t -> Avl t
+  | Ddecr (_, t) -> Avl t
+;;
+
+
+(* Exercise 22: Red-black trees *)
+
+type red = RED
+type black = BLACK
+type (_,_) sub_tree =
+  | Bleaf : (black, zero) sub_tree
+  | Rnode :
+      (black, 'n) sub_tree * int * (black, 'n) sub_tree -> (red, 'n) sub_tree
+  | Bnode :
+      ('cL, 'n) sub_tree * int * ('cR, 'n) sub_tree -> (black, 'n succ) sub_tree
+
+type rb_tree = Root : (black, 'n) sub_tree -> rb_tree
+;;
+
+type dir = LeftD | RightD
+
+type (_,_) ctxt =
+  | CNil : (black,'n) ctxt
+  | CRed : int * dir * (black,'n) sub_tree * (red,'n) ctxt -> (black,'n) ctxt
+  | CBlk : int * dir * ('c1,'n) sub_tree * (black, 'n succ) ctxt -> ('c,'n) ctxt
+;;
+
+let blacken = function
+    Rnode (l, e, r) -> Bnode (l, e, r)
+
+type _ crep =
+  | Red : red crep
+  | Black : black crep
+
+let color : type c n. (c,n) sub_tree -> c crep = function
+  | Bleaf -> Black
+  | Rnode _ -> Red
+  | Bnode _ -> Black
+;;
+
+let rec fill : type c n. (c,n) ctxt -> (c,n) sub_tree -> rb_tree =
+  fun ct t ->
+  match ct with
+  | CNil -> Root t
+  | CRed (e, LeftD, uncle, c) -> fill c (Rnode (uncle, e, t))
+  | CRed (e, RightD, uncle, c) -> fill c (Rnode (t, e, uncle))
+  | CBlk (e, LeftD, uncle, c) -> fill c (Bnode (uncle, e, t))
+  | CBlk (e, RightD, uncle, c) -> fill c (Bnode (t, e, uncle))
+;;
+let recolor d1 pE sib d2 gE uncle t =
+  match d1, d2 with
+  | LeftD, RightD -> Rnode (Bnode (sib, pE, t), gE, uncle)
+  | RightD, RightD -> Rnode (Bnode (t, pE, sib), gE, uncle)
+  | LeftD, LeftD -> Rnode (uncle, gE, Bnode (sib, pE, t))
+  | RightD, LeftD -> Rnode (uncle, gE, Bnode (t, pE, sib))
+;;
+let rotate d1 pE sib d2 gE uncle (Rnode (x, e, y)) =
+  match d1, d2 with
+  | RightD, RightD -> Bnode (Rnode (x,e,y), pE, Rnode (sib, gE, uncle))
+  | LeftD,  RightD -> Bnode (Rnode (sib, pE, x), e, Rnode (y, gE, uncle))
+  | LeftD,  LeftD  -> Bnode (Rnode (uncle, gE, sib), pE, Rnode (x,e,y))
+  | RightD, LeftD  -> Bnode (Rnode (uncle, gE, x), e, Rnode (y, pE, sib))
+;;
+let rec repair : type c n. (red,n) sub_tree -> (c,n) ctxt -> rb_tree =
+  fun t ct ->
+  match ct with
+  | CNil -> Root (blacken t)
+  | CBlk (e, LeftD, sib, c) -> fill c (Bnode (sib, e, t))
+  | CBlk (e, RightD, sib, c) -> fill c (Bnode (t, e, sib))
+  | CRed (e, dir, sib, CBlk (e', dir', uncle, ct)) ->
+      match color uncle with
+      | Red -> repair (recolor dir e sib dir' e' (blacken uncle) t) ct
+      | Black -> fill ct (rotate dir e sib dir' e' uncle t)
+;;
+let rec ins : type c n. int -> (c,n) sub_tree -> (c,n) ctxt -> rb_tree =
+  fun e t ct ->
+  match t with
+  | Rnode (l, e', r) ->
+      if e < e' then ins e l (CRed (e', RightD, r, ct))
+                else ins e r (CRed (e', LeftD, l, ct))
+  | Bnode (l, e', r) ->
+      if e < e' then ins e l (CBlk (e', RightD, r, ct))
+                else ins e r (CBlk (e', LeftD, l, ct))
+  | Bleaf -> repair (Rnode (Bleaf, e, Bleaf)) ct
+;;
+let insert e (Root t) = ins e t CNil
+;;
+
+(* 5.7 typed object languages using GADTs *)
+
+type _ term =
+  | Const : int -> int term
+  | Add   : (int * int -> int) term
+  | LT    : (int * int -> bool) term
+  | Ap    : ('a -> 'b) term * 'a term -> 'b term
+  | Pair  : 'a term * 'b term -> ('a * 'b) term
+
+let ex1 = Ap (Add, Pair (Const 3, Const 5))
+let ex2 = Pair (ex1, Const 1)
+
+let rec eval_term : type a. a term -> a = function
+  | Const x -> x
+  | Add -> fun (x,y) -> x+y
+  | LT  -> fun (x,y) -> x eval_term f (eval_term x)
+  | Pair(x,y) -> (eval_term x, eval_term y)
+
+type _ rep =
+  | Rint  : int rep
+  | Rbool : bool rep
+  | Rpair : 'a rep * 'b rep -> ('a * 'b) rep
+  | Rfun  : 'a rep * 'b rep -> ('a -> 'b) rep
+
+type (_,_) equal = Eq : ('a,'a) equal
+
+let rec rep_equal : type a b. a rep -> b rep -> (a, b) equal option =
+  fun ra rb ->
+  match ra, rb with
+  | Rint, Rint -> Some Eq
+  | Rbool, Rbool -> Some Eq
+  | Rpair (a1, a2), Rpair (b1, b2) ->
+      begin match rep_equal a1 b1 with
+      | None -> None
+      | Some Eq -> match rep_equal a2 b2 with
+        | None -> None
+        | Some Eq -> Some Eq
+      end
+  | Rfun (a1, a2), Rfun (b1, b2) ->
+      begin match rep_equal a1 b1 with
+      | None -> None
+      | Some Eq -> match rep_equal a2 b2 with
+        | None -> None
+        | Some Eq -> Some Eq
+      end
+  | _ -> None
+;;
+
+type assoc = Assoc : string * 'a rep * 'a -> assoc
+
+let rec assoc : type a. string -> a rep -> assoc list -> a =
+  fun x r -> function
+  | [] -> raise Not_found
+  | Assoc (x', r', v) :: env ->
+      if x = x' then
+        match rep_equal r r' with
+        | None -> failwith ("Wrong type for " ^ x)
+        | Some Eq -> v
+      else assoc x r env
+
+type _ term =
+  | Var   : string * 'a rep -> 'a term
+  | Abs   : string * 'a rep * 'b term -> ('a -> 'b) term
+  | Const : int -> int term
+  | Add   : (int * int -> int) term
+  | LT    : (int * int -> bool) term
+  | Ap    : ('a -> 'b) term * 'a term -> 'b term
+  | Pair  : 'a term * 'b term -> ('a * 'b) term
+
+let rec eval_term : type a. assoc list -> a term -> a =
+  fun env -> function
+  | Var (x, r) -> assoc x r env
+  | Abs (x, r, e) -> fun v -> eval_term (Assoc (x, r, v) :: env) e
+  | Const x -> x
+  | Add -> fun (x,y) -> x+y
+  | LT  -> fun (x,y) -> x eval_term env f (eval_term env x)
+  | Pair(x,y) -> (eval_term env x, eval_term env y)
+;;
+
+let ex3 = Abs ("x", Rint, Ap (Add, Pair (Var("x",Rint), Var("x",Rint))))
+let ex4 = Ap (ex3, Const 3)
+
+let v4 = eval_term [] ex4
+;;
+
+(* 5.9/5.10 Language with binding *)
+
+type rnil = RNIL
+type ('a,'b,'c) rcons = RCons of 'a * 'b * 'c
+
+type _ is_row =
+  | Rnil  : rnil is_row
+  | Rcons : 'c is_row -> ('a,'b,'c) rcons is_row
+
+type (_,_) lam =
+  | Const : int -> ('e, int) lam
+  | Var : 'a -> (('a,'t,'e) rcons, 't) lam
+  | Shift : ('e,'t) lam -> (('a,'q,'e) rcons, 't) lam
+  | Abs : 'a * (('a,'s,'e) rcons, 't) lam -> ('e, 's -> 't) lam
+  | App : ('e, 's -> 't) lam * ('e, 's) lam -> ('e, 't) lam
+
+type x = X
+type y = Y
+
+let ex1 = App (Var X, Shift (Var Y))
+let ex2 = Abs (X, Abs (Y, App (Shift (Var X), Var Y)))
+;;
+
+type _ env =
+  | Enil : rnil env
+  | Econs : 'a * 't * 'e env -> ('a, 't, 'e) rcons env
+
+let rec eval_lam : type e t. e env -> (e, t) lam -> t =
+  fun env m ->
+  match env, m with
+  | _, Const n -> n
+  | Econs (_, v, r), Var _ -> v
+  | Econs (_, _, r), Shift e -> eval_lam r e
+  | _, Abs (n, body) -> fun x -> eval_lam (Econs (n, x, env)) body
+  | _, App (f, x)    -> eval_lam env f (eval_lam env x)
+;;
+
+type add = Add
+type suc = Suc
+
+let env0 = Econs (Zero, 0, Econs (Suc, succ, Econs (Add, (+), Enil)))
+
+let _0 : (_, int) lam = Var Zero
+let suc x = App (Shift (Var Suc : (_, int -> int) lam), x)
+let _1 = suc _0
+let _2 = suc _1
+let _3 = suc _2
+let add = Shift (Shift (Var Add : (_, int -> int -> int) lam))
+
+let double = Abs (X, App (App (Shift add, Var X), Var X))
+let ex3 = App (double, _3)
+;;
+
+let v3 = eval_lam env0 ex3
+;;
+
+(* 5.13: Constructing typing derivations at runtime *)
+
+(* Modified slightly to use the language of 5.10, since this is more fun.
+   Of course this works also with the language of 5.12. *)
+
+type _ rep =
+  | I : int rep
+  | Ar : 'a rep * 'b rep -> ('a -> 'b) rep
+
+let rec compare : type a b. a rep -> b rep -> (string, (a,b) equal) sum =
+  fun a b ->
+  match a, b with
+  | I, I -> Inr Eq
+  | Ar(x,y), Ar(s,t) ->
+      begin match compare x s with
+      | Inl _ as e -> e
+      | Inr Eq -> match compare y t with
+        | Inl _ as e -> e
+        | Inr Eq as e -> e
+      end
+  | I, Ar _ -> Inl "I <> Ar _"
+  | Ar _, I -> Inl "Ar _ <> I"
+;;
+
+type term =
+  | C of int
+  | Ab : string * 'a rep * term -> term
+  | Ap of term * term
+  | V of string
+
+type _ ctx =
+  | Cnil : rnil ctx
+  | Ccons : 't * string * 'x rep * 'e ctx -> ('t,'x,'e) rcons ctx
+;;
+
+type _ checked =
+  | Cerror of string
+  | Cok : ('e,'t) lam * 't rep -> 'e checked
+
+let rec lookup : type e. string -> e ctx -> e checked =
+  fun name ctx ->
+  match ctx with
+  | Cnil -> Cerror ("Name not found: " ^ name)
+  | Ccons (l,s,t,rs) ->
+      if s = name then Cok (Var l,t) else
+      match lookup name rs with
+      | Cerror m -> Cerror m
+      | Cok (v, t) -> Cok (Shift v, t)
+;;
+
+let rec tc : type n e. n nat -> e ctx -> term -> e checked =
+  fun n ctx t ->
+  match t with
+  | V s -> lookup s ctx
+  | Ap(f,x) ->
+      begin match tc n ctx f with
+      | Cerror _ as e -> e
+      | Cok (f', ft) -> match tc n ctx x with
+        | Cerror _ as e -> e
+        | Cok (x', xt) ->
+            match ft with
+            | Ar (a, b) ->
+                begin match compare a xt with
+                | Inl s -> Cerror s
+                | Inr Eq -> Cok (App (f',x'), b)
+                end
+            | _ -> Cerror "Non fun in Ap"
+      end
+  | Ab(s,t,body) ->
+      begin match tc (NS n) (Ccons (n, s, t, ctx)) body with
+      | Cerror _ as e -> e
+      | Cok (body', et) -> Cok (Abs (n, body'), Ar (t, et))
+      end
+  | C m -> Cok (Const m, I)
+;;
+
+let ctx0 =
+  Ccons (Zero, "0", I,
+         Ccons (Suc, "S", Ar(I,I),
+                Ccons (Add, "+", Ar(I,Ar(I,I)), Cnil)))
+
+let ex1 = Ab ("x", I, Ap(Ap(V"+",V"x"),V"x"));;
+let c1 = tc NZ ctx0 ex1;;
+let ex2 = Ap (ex1, C 3);;
+let c2 = tc NZ ctx0 ex2;;
+
+let eval_checked env = function
+  | Cerror s -> failwith s
+  | Cok (e, I) -> (eval_lam env e : int)
+  | Cok _ -> failwith "Can only evaluate expressions of type I"
+;;
+
+let v2 = eval_checked env0 c2 ;;
+
+(* 5.12 Soundness *)
+
+type pexp = PEXP
+type pval = PVAL
+type _ mode =
+  | Pexp : pexp mode
+  | Pval : pval mode
+
+type ('a,'b) tarr = TARR
+type tint = TINT
+
+type (_,_) rel =
+  | IntR : (tint, int) rel
+  | IntTo : ('b, 's) rel -> ((tint, 'b) tarr, int -> 's) rel
+
+type (_,_,_) lam =
+  | Const : ('a,'b) rel * 'b -> (pval, 'env, 'a) lam
+  | Var : 'a -> (pval, ('a,'t,'e) rcons, 't) lam
+  | Shift : ('m,'e,'t) lam -> ('m, ('a,'q,'e) rcons, 't) lam
+  | Lam : 'a * ('m, ('a,'s,'e) rcons, 't) lam -> (pval, 'e, ('s,'t) tarr) lam
+  | App : ('m1, 'e, ('s,'t) tarr) lam * ('m2, 'e, 's) lam -> (pexp, 'e, 't) lam
+;;
+
+let ex1 = App (Lam (X, Var X), Const (IntR, 3))
+
+let rec mode : type m e t. (m,e,t) lam -> m mode = function
+  | Lam (v, body) -> Pval
+  | Var v -> Pval
+  | Const (r, v) -> Pval
+  | Shift e -> mode e
+  | App _ -> Pexp
+;;
+
+type (_,_) sub =
+  | Id : ('r,'r) sub
+  | Bind : 't * ('m,'r2,'x) lam * ('r,'r2) sub -> (('t,'x,'r) rcons, 'r2) sub
+  | Push : ('r1,'r2) sub -> (('a,'b,'r1) rcons, ('a,'b,'r2) rcons) sub
+
+type (_,_) lam' = Ex : ('m, 's, 't) lam -> ('s,'t) lam'
+;;
+
+let rec subst : type m1 r t s. (m1,r,t) lam -> (r,s) sub -> (s,t) lam' =
+  fun t s ->
+  match t, s with
+  | _, Id -> Ex t
+  | Const(r,c), sub -> Ex (Const (r,c))
+  | Var v, Bind (x, e, r) -> Ex e
+  | Var v, Push sub -> Ex (Var v)
+  | Shift e, Bind (_, _, r) -> subst e r
+  | Shift e, Push sub ->
+      (match subst e sub with Ex a -> Ex (Shift a))
+  | App(f,x), sub ->
+      (match subst f sub, subst x sub with Ex g, Ex y -> Ex (App (g,y)))
+  | Lam(v,x), sub ->
+      (match subst x (Push sub) with Ex body -> Ex (Lam (v, body)))
+;;
+
+type closed = rnil
+
+type 'a rlam = ((pexp,closed,'a) lam, (pval,closed,'a) lam) sum ;;
+
+let rec rule : type a b.
+  (pval, closed, (a,b) tarr) lam -> (pval, closed, a) lam -> b rlam =
+  fun v1 v2 ->
+  match v1, v2 with
+  | Lam(x,body), v ->
+      begin
+        match subst body (Bind (x, v, Id)) with Ex term ->
+        match mode term with
+        | Pexp -> Inl term
+        | Pval -> Inr term
+      end
+  | Const (IntTo b, f), Const (IntR, x) ->
+      Inr (Const (b, f x))
+;;
+let rec onestep : type m t. (m,closed,t) lam -> t rlam = function
+  | Lam (v, body) -> Inr (Lam (v, body))
+  | Const (r, v)  -> Inr (Const (r, v))
+  | App (e1, e2) ->
+      match mode e1, mode e2 with
+      | Pexp, _->
+          begin match onestep e1 with
+          | Inl e -> Inl(App(e,e2))
+          | Inr v -> Inl(App(v,e2))
+          end
+      | Pval, Pexp ->
+          begin match onestep e2 with
+          | Inl e -> Inl(App(e1,e))
+          | Inr v -> Inl(App(e1,v))
+          end
+      | Pval, Pval -> rule e1 e2
+;;
+type ('env, 'a) var =
+ | Zero : ('a * 'env, 'a) var
+ | Succ : ('env, 'a) var -> ('b * 'env, 'a) var
+;;
+type ('env, 'a) typ =
+ | Tint : ('env, int) typ
+ | Tbool : ('env, bool) typ
+ | Tvar : ('env, 'a) var -> ('env, 'a) typ
+;;
+let f : type env a. (env, a) typ -> (env, a) typ -> int = fun ta tb ->
+ match ta, tb with
+   | Tint, Tint -> 0
+   | Tbool, Tbool -> 1
+   | Tvar var, tb -> 2
+   | _ -> .   (* error *)
+;;
+(* let x = f Tint (Tvar Zero) ;; *)
+type inkind = [ `Link | `Nonlink ]
+
+type _ inline_t =
+   | Text: string -> [< inkind > `Nonlink ] inline_t
+   | Bold: 'a inline_t list -> 'a inline_t
+   | Link: string -> [< inkind > `Link ] inline_t
+   | Mref: string * [ `Nonlink ] inline_t list -> [< inkind > `Link ] inline_t
+;;
+
+let uppercase seq =
+   let rec process: type a. a inline_t -> a inline_t = function
+       | Text txt       -> Text (String.uppercase_ascii txt)
+       | Bold xs        -> Bold (List.map process xs)
+       | Link lnk       -> Link lnk
+       | Mref (lnk, xs) -> Mref (lnk, List.map process xs)
+   in List.map process seq
+;;
+
+type ast_t =
+   | Ast_Text of string
+   | Ast_Bold of ast_t list
+   | Ast_Link of string
+   | Ast_Mref of string * ast_t list
+;;
+
+let inlineseq_from_astseq seq =
+   let rec process_nonlink = function
+       | Ast_Text txt  -> Text txt
+       | Ast_Bold xs   -> Bold (List.map process_nonlink xs)
+       | _             -> assert false in
+   let rec process_any = function
+       | Ast_Text txt       -> Text txt
+       | Ast_Bold xs        -> Bold (List.map process_any xs)
+       | Ast_Link lnk       -> Link lnk
+       | Ast_Mref (lnk, xs) -> Mref (lnk, List.map process_nonlink xs)
+   in List.map process_any seq
+;;
+
+(* OK *)
+type _ linkp =
+ | Nonlink : [ `Nonlink ] linkp
+ | Maylink : inkind linkp
+;;
+let inlineseq_from_astseq seq =
+ let rec process : type a. a linkp -> ast_t -> a inline_t =
+   fun allow_link ast ->
+     match (allow_link, ast) with
+     | (Maylink, Ast_Text txt)    -> Text txt
+     | (Nonlink, Ast_Text txt)    -> Text txt
+     | (x, Ast_Bold xs)           -> Bold (List.map (process x) xs)
+     | (Maylink, Ast_Link lnk)    -> Link lnk
+     | (Nonlink, Ast_Link _)      -> assert false
+     | (Maylink, Ast_Mref (lnk, xs)) ->
+         Mref (lnk, List.map (process Nonlink) xs)
+     | (Nonlink, Ast_Mref _)      -> assert false
+   in List.map (process Maylink) seq
+;;
+
+(* Bad *)
+type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2
+;;
+let inlineseq_from_astseq seq =
+let rec process : type a. a linkp2 -> ast_t -> a inline_t =
+  fun allow_link ast ->
+    match (allow_link, ast) with
+    | (Kind _, Ast_Text txt)    -> Text txt
+    | (x, Ast_Bold xs)           -> Bold (List.map (process x) xs)
+    | (Kind Maylink, Ast_Link lnk)    -> Link lnk
+    | (Kind Nonlink, Ast_Link _)      -> assert false
+    | (Kind Maylink, Ast_Mref (lnk, xs)) ->
+        Mref (lnk, List.map (process (Kind Nonlink)) xs)
+    | (Kind Nonlink, Ast_Mref _)      -> assert false
+  in List.map (process (Kind Maylink)) seq
+;;
+module Add (T : sig type two end) =
+struct
+  type _ t =
+  | One : [`One] t
+  | Two : T.two t
+
+  let add (type a) : a t * a t -> string = function
+    | One, One -> "two"
+    | Two, Two -> "four"
+end;;
+module B : sig
+ type (_, _) t = Eq: ('a, 'a) t
+ val f: 'a -> 'b -> ('a, 'b) t
+end
+=
+struct
+ type (_, _) t = Eq: ('a, 'a) t
+ let f t1 t2 = Obj.magic Eq
+end;;
+
+let of_type: type a. a -> a = fun x ->
+  match B.f x 4 with
+  | Eq -> 5
+;;
+type _ constant =
+  | Int: int -> int constant
+  | Bool: bool -> bool constant
+
+type (_, _, _) binop =
+  | Eq: ('a, 'a, bool) binop
+  | Leq: ('a, 'a, bool) binop
+  | Add: (int, int, int) binop
+
+let eval (type a) (type b) (type c) (bop:(a,b,c) binop) (x:a constant)
+         (y:b constant) : c constant =
+  match bop, x, y with
+  | Eq, Bool x, Bool y -> Bool (if x then y else not y)
+  | Leq, Int x, Int y -> Bool (x <= y)
+  | Leq, Bool x, Bool y -> Bool (x <= y)
+  | Add, Int x, Int y -> Int (x + y)
+
+let _ = eval Eq (Int 2) (Int 3)
+type tag = [`TagA | `TagB | `TagC];;
+
+type 'a poly =
+    AandBTags : [< `TagA of int | `TagB ] poly
+  | ATag : [< `TagA of int] poly
+(* constraint 'a = [< `TagA of int | `TagB] *)
+;;
+
+let intA = function `TagA i -> i
+let intB = function `TagB -> 4
+;;
+
+let intAorB = function
+    `TagA i -> i
+  | `TagB -> 4
+;;
+
+type _ wrapPoly =
+    WrapPoly : 'a poly -> ([< `TagA of int | `TagB] as 'a) wrapPoly
+;;
+
+let example6 : type a. a wrapPoly -> (a -> int) =
+  fun w  ->
+    match w with
+    | WrapPoly ATag -> intA
+    | WrapPoly _ -> intA (* This should not be allowed *)
+;;
+
+let _ =  example6 (WrapPoly AandBTags) `TagB (* This causes a seg fault *)
+;;
+module F(S : sig type 'a t end) = struct
+  type _ ab =
+      A : int S.t ab
+    | B : float S.t ab
+
+  let f : int S.t ab -> float S.t ab -> string =
+    fun (l : int S.t ab) (r : float S.t ab) -> match l, r with
+    | A, B -> "f A B"
+end;;
+
+module F(S : sig type 'a t end) = struct
+  type a = int * int
+  type b = int -> int
+
+  type _ ab =
+      A : a S.t ab
+    | B : b S.t ab
+
+  let f : a S.t ab -> b S.t ab -> string =
+    fun l r -> match l, r with
+    | A, B -> "f A B"
+end;;
+type (_, _) t =
+    Any : ('a, 'b) t
+  | Eq : ('a, 'a) t
+;;
+
+module M :
+sig
+  type s = private [> `A]
+  val eq : (s, [`A | `B]) t
+end =
+struct
+  type s = [`A | `B]
+  let eq = Eq
+end;;
+
+let f : (M.s, [`A | `B]) t -> string = function
+  | Any -> "Any"
+;;
+
+let () = print_endline (f M.eq) ;;
+
+module N :
+sig
+  type s = private < a : int; .. >
+  val eq : (s, ) t
+end =
+struct
+  type s = 
+  let eq = Eq
+end
+;;
+
+let f : (N.s, ) t -> string = function
+  | Any -> "Any"
+;;
+type (_, _) comp =
+  | Eq : ('a, 'a) comp
+  | Diff : ('a, 'b) comp
+;;
+
+module U = struct type t = T end;;
+
+module M : sig
+  type t = T
+  val comp : (U.t, t) comp
+end = struct
+  include U
+  let comp = Eq
+end;;
+
+match M.comp with | Diff -> false;;
+
+module U = struct type t = {x : int} end;;
+
+module M : sig
+  type t = {x : int}
+  val comp : (U.t, t) comp
+end = struct
+  include U
+  let comp = Eq
+end;;
+
+match M.comp with | Diff -> false;;
+type 'a t = T of 'a
+type 'a s = S of 'a
+
+type (_, _) eq = Refl : ('a, 'a) eq;;
+
+let f : (int s, int t) eq -> unit = function Refl -> ();;
+
+module M (S : sig type 'a t = T of 'a type 'a s = T of 'a end) =
+struct let f : ('a S.s, 'a S.t) eq -> unit = function Refl -> () end;;
+type _ nat =
+    Zero : [`Zero] nat
+  | Succ : 'a nat -> [`Succ of 'a] nat;;
+type 'a pre_nat = [`Zero | `Succ of 'a];;
+type aux =
+  | Aux : [`Succ of [<[<[<[`Zero] pre_nat] pre_nat] pre_nat]] nat -> aux;;
+
+let f (Aux x) =
+  match x with
+  | Succ Zero -> "1"
+  | Succ (Succ Zero) -> "2"
+  | Succ (Succ (Succ Zero)) -> "3"
+  | Succ (Succ (Succ (Succ Zero))) -> "4"
+  | _ -> .  (* error *)
+;;
+type _ t = C : ((('a -> 'o) -> 'o) -> ('b -> 'o) -> 'o) t
+let f : type a o. ((a -> o) -> o) t -> (a -> o) -> o =
+ fun C k -> k (fun x -> x);;
+type (_, _) t =
+ A : ('a, 'a) t
+| B : string -> ('a, 'b) t
+;;
+
+module M (A : sig module type T end) (B : sig module type T end) =
+struct
+ let f : ((module A.T), (module B.T)) t -> string = function
+   | B s -> s
+end;;
+
+module A = struct module type T = sig end end;;
+
+module N = M(A)(A);;
+
+let x = N.f A;;
+type 'a visit_action
+
+type insert
+
+type 'a local_visit_action
+
+type ('a, 'result, 'visit_action) context =
+  | Local : ('a, ('a * insert) as 'result, 'a local_visit_action) context
+  | Global : ('a, 'a, 'a visit_action) context
+;;
+
+let vexpr (type visit_action)
+    : (_, _, visit_action) context -> _ -> visit_action =
+  function
+  | Local -> fun _ -> raise Exit
+  | Global -> fun _ -> raise Exit
+;;
+
+let vexpr (type visit_action)
+    : ('a, 'result, visit_action) context -> 'a -> visit_action =
+  function
+  | Local -> fun _ -> raise Exit
+  | Global -> fun _ -> raise Exit
+;;
+
+let vexpr (type result) (type visit_action)
+    : (unit, result, visit_action) context -> unit -> visit_action =
+  function
+  | Local -> fun _ -> raise Exit
+  | Global -> fun _ -> raise Exit
+;;
+module A = struct
+    type nil = Cstr
+  end
+open A
+;;
+
+type _ s =
+  | Nil : nil s
+  | Cons : 't s -> ('h -> 't) s
+
+type ('stack, 'typ) var =
+  | Head : (('typ -> _) s, 'typ) var
+  | Tail : ('tail s, 'typ) var -> ((_ -> 'tail) s, 'typ) var
+
+type _ lst =
+  | CNil : nil lst
+  | CCons : 'h * ('t lst) -> ('h -> 't) lst
+;;
+
+let rec get_var : type stk ret. (stk s, ret) var -> stk lst -> ret = fun n s ->
+  match n, s with
+  | Head, CCons (h, _) -> h
+  | Tail n', CCons (_, t) -> get_var n' t
+;;
+type 'a t = [< `Foo | `Bar] as 'a;;
+type 'a s = [< `Foo | `Bar | `Baz > `Bar] as 'a;;
+
+type 'a first = First : 'a second -> ('b t as 'a) first
+and 'a second = Second : ('b s as 'a) second;;
+
+type aux = Aux : 'a t second * ('a -> int) -> aux;;
+
+let it : 'a. [< `Bar | `Foo > `Bar ] as 'a = `Bar;;
+
+let g (Aux(Second, f)) = f it;;
+type (_, _) eqp = Y : ('a, 'a) eqp | N : string -> ('a, 'b) eqp
+let f : ('a list, 'a) eqp -> unit = function N s -> print_string s;;
+
+module rec A :  sig type t = B.t list end =
+  struct type t = B.t list end
+and B : sig  type t val eq : (B.t list, t) eqp end =
+  struct
+    type t = A.t
+    let eq = Y
+  end;;
+
+f B.eq;;
+type (_, _) t =
+  | Nil : ('tl, 'tl) t
+  | Cons : 'a * ('b, 'tl) t -> ('a * 'b, 'tl) t;;
+
+let get1 (Cons (x, _) : (_ * 'a, 'a) t) = x ;; (* warn, cf PR#6993 *)
+
+let get1' = function
+  | (Cons (x, _) : (_ * 'a, 'a) t) -> x
+  | Nil -> assert false ;; (* ok *)
+type _ t =
+  Int : int -> int t | String : string -> string t | Same : 'l t -> 'l t;;
+let rec f = function Int x -> x | Same s -> f s;;
+type 'a tt = 'a t =
+  Int : int -> int tt | String : string -> string tt | Same : 'l1 t -> 'l2 tt;;
+type _ t = I : int t;;
+
+let f (type a) (x : a t) =
+  let module M = struct
+    let (I : a t) = x     (* fail because of toplevel let *)
+    let x = (I : a t)
+  end in
+  () ;;
+
+(* extra example by Stephen Dolan, using recursive modules *)
+(* Should not be allowed! *)
+type (_,_) eq = Refl : ('a, 'a) eq;;
+
+let bad (type a) =
+ let module N = struct
+   module rec M : sig
+     val e : (int, a) eq
+   end = struct
+     let (Refl : (int, a) eq) = M.e  (* must fail for soundness *)
+     let e : (int, a) eq = Refl
+   end
+ end in N.M.e
+;;
+type +'a n = private int
+type nil = private Nil_type
+type (_,_) elt =
+  | Elt_fine: 'nat n -> ('l,'nat * 'l) elt
+  | Elt: 'nat n -> ('l,'nat -> 'l) elt
+type _ t = Nil : nil t | Cons : ('x, 'fx) elt * 'x t -> 'fx t;;
+
+let undetected: ('a -> 'b -> nil) t -> 'a n -> 'b n -> unit = fun sh i j ->
+  let Cons(Elt dim, _) = sh in ()
+;;
+type _ t = T : int t;;
+
+(* Should raise Not_found *)
+let _ = match (raise Not_found : float t) with _ -> .;;
+type (_, _) eq = Eq : ('a, 'a) eq | Neq : int -> ('a, 'b) eq;;
+type 'a t;;
+let f (type a) (Neq n : (a, a t) eq) = n;;   (* warn! *)
+
+module F (T : sig type _ t end) = struct
+ let f (type a) (Neq n : (a, a T.t) eq) = n  (* warn! *)
+end;;
+(* First-Order Unification by Structural Recursion *)
+(* Conor McBride, JFP 13(6) *)
+(* http://strictlypositive.org/publications.html *)
+
+(* This is a translation of the code part to ocaml *)
+(* Of course, we do not prove other properties, not even termination *)
+
+(* 2.2 Inductive Families *)
+
+type zero = Zero
+type _ succ = Succ
+type _ nat =
+  | NZ : zero nat
+  | NS : 'a nat -> 'a succ nat
+
+type _ fin =
+  | FZ : 'a succ fin
+  | FS : 'a fin -> 'a succ fin
+
+(* We cannot define
+     val empty : zero fin -> 'a
+   because we cannot write an empty pattern matching.
+   This might be useful to have *)
+
+(* In place, prove that the parameter is 'a succ *)
+type _ is_succ = IS : 'a succ is_succ
+
+let fin_succ : type n. n fin -> n is_succ = function
+  | FZ -> IS
+  | FS _ -> IS
+;;
+
+(* 3 First-Order Terms, Renaming and Substitution *)
+
+type 'a term =
+  | Var of 'a fin
+  | Leaf
+  | Fork of 'a term * 'a term
+
+let var x = Var x
+
+let lift r : 'm fin -> 'n term = fun x -> Var (r x)
+
+let rec pre_subst f = function
+  | Var x -> f x
+  | Leaf -> Leaf
+  | Fork (t1, t2) -> Fork (pre_subst f t1, pre_subst f t2)
+
+let comp_subst f g (x : 'a fin) = pre_subst f (g x)
+(*  val comp_subst :
+    ('b fin -> 'c term) -> ('a fin -> 'b term) -> 'a fin -> 'c term *)
+;;
+
+(* 4 The Occur-Check, through thick and thin *)
+
+let rec thin : type n. n succ fin -> n fin -> n succ fin =
+  fun x y -> match x, y with
+  | FZ, y    -> FS y
+  | FS x, FZ -> FZ
+  | FS x, FS y -> FS (thin x y)
+
+let bind t f =
+  match t with
+  | None   -> None
+  | Some x -> f x
+(* val bind : 'a option -> ('a -> 'b option) -> 'b option *)
+
+let rec thick : type n. n succ fin -> n succ fin -> n fin option =
+  fun x y -> match x, y with
+  | FZ, FZ   -> None
+  | FZ, FS y -> Some y
+  | FS x, FZ -> let IS = fin_succ x in Some FZ
+  | FS x, FS y ->
+      let IS = fin_succ x in bind (thick x y) (fun x -> Some (FS x))
+
+let rec check : type n. n succ fin -> n succ term -> n term option =
+  fun x t -> match t with
+  | Var y -> bind (thick x y) (fun x -> Some (Var x))
+  | Leaf  -> Some Leaf
+  | Fork (t1, t2) ->
+      bind (check x t1) (fun t1 ->
+        bind (check x t2) (fun t2 -> Some (Fork (t1, t2))))
+
+let subst_var x t' y =
+  match thick x y with
+  | None -> t'
+  | Some y' -> Var y'
+(* val subst_var : 'a succ fin -> 'a term -> 'a succ fin -> 'a term *)
+
+let subst x t' = pre_subst (subst_var x t')
+(* val subst : 'a succ fin -> 'a term -> 'a succ term -> 'a term *)
+;;
+
+(* 5 A Refinement of Substitution *)
+
+type (_,_) alist =
+  | Anil  : ('n,'n) alist
+  | Asnoc : ('m,'n) alist * 'm term * 'm succ fin -> ('m succ, 'n) alist
+
+let rec sub : type m n. (m,n) alist -> m fin -> n term = function
+  | Anil -> var
+  | Asnoc (s, t, x) -> comp_subst (sub s) (subst_var x t)
+
+let rec append : type m n l. (m,n) alist -> (l,m) alist -> (l,n) alist =
+  fun r s -> match s with
+  | Anil -> r
+  | Asnoc (s, t, x) -> Asnoc (append r s, t, x)
+
+type _ ealist = EAlist : ('a,'b) alist -> 'a ealist
+
+let asnoc a t' x = EAlist (Asnoc (a, t', x))
+
+(* Extra work: we need sub to work on ealist too, for examples *)
+let rec weaken_fin : type n. n fin -> n succ fin = function
+  | FZ -> FZ
+  | FS x -> FS (weaken_fin x)
+
+let weaken_term t = pre_subst (fun x -> Var (weaken_fin x)) t
+
+let rec weaken_alist : type m n. (m, n) alist -> (m succ, n succ) alist =
+  function
+    | Anil -> Anil
+    | Asnoc (s, t, x) -> Asnoc (weaken_alist s, weaken_term t, weaken_fin x)
+
+let rec sub' : type m. m ealist -> m fin -> m term = function
+  | EAlist Anil -> var
+  | EAlist (Asnoc (s, t, x)) ->
+      comp_subst (sub' (EAlist (weaken_alist s)))
+        (fun t' -> weaken_term (subst_var x t t'))
+
+let subst' d = pre_subst (sub' d)
+(*  val subst' : 'a ealist -> 'a term -> 'a term *)
+;;
+
+(* 6 First-Order Unification *)
+
+let flex_flex x y =
+  match thick x y with
+  | Some y' -> asnoc Anil (Var y') x
+  | None -> EAlist Anil
+(* val flex_flex : 'a succ fin -> 'a succ fin -> 'a succ ealist *)
+
+let flex_rigid x t =
+  bind (check x t) (fun t' -> Some (asnoc Anil t' x))
+(* val flex_rigid : 'a succ fin -> 'a succ term -> 'a succ ealist option *)
+
+let rec amgu : type m. m term -> m term -> m ealist -> m ealist option =
+  fun s t acc -> match s, t, acc with
+  | Leaf, Leaf, _   -> Some acc
+  | Leaf, Fork _, _ -> None
+  | Fork _, Leaf, _ -> None
+  | Fork (s1, s2), Fork (t1, t2), _ ->
+      bind (amgu s1 t1 acc) (amgu s2 t2)
+  | Var x, Var y, EAlist Anil -> let IS = fin_succ x in Some (flex_flex x y)
+  | Var x, t,     EAlist Anil -> let IS = fin_succ x in flex_rigid x t
+  | t, Var x,     EAlist Anil -> let IS = fin_succ x in flex_rigid x t
+  | s, t, EAlist(Asnoc(d,r,z)) ->
+      bind (amgu (subst z r s) (subst z r t) (EAlist d))
+           (fun (EAlist d) -> Some (asnoc d r z))
+
+let mgu s t = amgu s t (EAlist Anil)
+(* val mgu : 'a term -> 'a term -> 'a ealist option *)
+;;
+
+let s = Fork (Var FZ, Fork (Var (FS (FS FZ)), Leaf))
+let t = Fork (Var (FS FZ), Var (FS FZ))
+let d = match mgu s t with Some x -> x | None -> failwith "mgu"
+let s' = subst' d s
+let t' = subst' d t
+;;
+(* Injectivity *)
+
+type (_, _) eq = Refl : ('a, 'a) eq
+
+let magic : 'a 'b. 'a -> 'b =
+  fun (type a b) (x : a) ->
+    let module M =
+      (functor (T : sig type 'a t end) ->
+       struct
+         let f (Refl : (a T.t, b T.t) eq) = (x :> b)
+       end)
+        (struct type 'a t = unit end)
+    in M.f Refl
+;;
+
+(* Variance and subtyping *)
+
+type (_, +_) eq = Refl : ('a, 'a) eq
+
+let magic : 'a 'b. 'a -> 'b =
+  fun (type a) (type b) (x : a) ->
+    let bad_proof (type a) =
+      (Refl : (< m : a>, ) eq :> (, < >) eq) in
+    let downcast : type a. (a, < >) eq -> < > -> a =
+      fun (type a) (Refl : (a, < >) eq) (s : < >) -> (s :> a) in
+    (downcast bad_proof ((object method m = x end) :> < >)) # m
+;;
+
+(* Record patterns *)
+
+type _ t =
+  | IntLit : int t
+  | BoolLit : bool t
+
+let check : type s . s t * s -> bool = function
+  | BoolLit, false -> false
+  | IntLit , 6 -> false
+;;
+
+type ('a, 'b) pair = { fst : 'a; snd : 'b }
+
+let check : type s . (s t, s) pair -> bool = function
+  | {fst = BoolLit; snd = false} -> false
+  | {fst = IntLit ; snd =  6} -> false
+;;
+module type S = sig type t [@@immediate] end;;
+module F (M : S) : S = M;;
+[%%expect{|
+module type S = sig type t [@@immediate] end
+module F : functor (M : S) -> S
+|}];;
+
+(* VALID DECLARATIONS *)
+
+module A = struct
+  (* Abstract types can be immediate *)
+  type t [@@immediate]
+
+  (* [@@immediate] tag here is unnecessary but valid since t has it *)
+  type s = t [@@immediate]
+
+  (* Again, valid alias even without tag *)
+  type r = s
+
+  (* Mutually recursive declarations work as well *)
+  type p = q [@@immediate]
+  and q = int
+end;;
+[%%expect{|
+module A :
+  sig
+    type t [@@immediate]
+    type s = t [@@immediate]
+    type r = s
+    type p = q [@@immediate]
+    and q = int
+  end
+|}];;
+
+(* Valid using with constraints *)
+module type X = sig type t end;;
+module Y = struct type t = int end;;
+module Z = ((Y : X with type t = int) : sig type t [@@immediate] end);;
+[%%expect{|
+module type X = sig type t end
+module Y : sig type t = int end
+module Z : sig type t [@@immediate] end
+|}];;
+
+(* Valid using an explicit signature *)
+module M_valid : S = struct type t = int end;;
+module FM_valid = F (struct type t = int end);;
+[%%expect{|
+module M_valid : S
+module FM_valid : S
+|}];;
+
+(* Practical usage over modules *)
+module Foo : sig type t val x : t ref end = struct
+  type t = int
+  let x = ref 0
+end;;
+[%%expect{|
+module Foo : sig type t val x : t ref end
+|}];;
+
+module Bar : sig type t [@@immediate] val x : t ref end = struct
+  type t = int
+  let x = ref 0
+end;;
+[%%expect{|
+module Bar : sig type t [@@immediate] val x : t ref end
+|}];;
+
+let test f =
+  let start = Sys.time() in f ();
+  (Sys.time() -. start);;
+[%%expect{|
+val test : (unit -> 'a) -> float = 
+|}];;
+
+let test_foo () =
+  for i = 0 to 100_000_000 do
+    Foo.x := !Foo.x
+  done;;
+[%%expect{|
+val test_foo : unit -> unit = 
+|}];;
+
+let test_bar () =
+  for i = 0 to 100_000_000 do
+    Bar.x := !Bar.x
+  done;;
+[%%expect{|
+val test_bar : unit -> unit = 
+|}];;
+
+(* Uncomment these to test. Should see substantial speedup!
+let () = Printf.printf "No @@immediate: %fs\n" (test test_foo)
+let () = Printf.printf "With @@immediate: %fs\n" (test test_bar) *)
+
+
+(* INVALID DECLARATIONS *)
+
+(* Cannot directly declare a non-immediate type as immediate *)
+module B = struct
+  type t = string [@@immediate]
+end;;
+[%%expect{|
+Line _, characters 2-31:
+Error: Types marked with the immediate attribute must be
+       non-pointer types like int or bool
+|}];;
+
+(* Not guaranteed that t is immediate, so this is an invalid declaration *)
+module C = struct
+  type t
+  type s = t [@@immediate]
+end;;
+[%%expect{|
+Line _, characters 2-26:
+Error: Types marked with the immediate attribute must be
+       non-pointer types like int or bool
+|}];;
+
+(* Can't ascribe to an immediate type signature with a non-immediate type *)
+module D : sig type t [@@immediate] end = struct
+  type t = string
+end;;
+[%%expect{|
+Line _, characters 42-70:
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = string end
+       is not included in
+         sig type t [@@immediate] end
+       Type declarations do not match:
+         type t = string
+       is not included in
+         type t [@@immediate]
+       the first is not an immediate type.
+|}];;
+
+(* Same as above but with explicit signature *)
+module M_invalid : S = struct type t = string end;;
+module FM_invalid = F (struct type t = string end);;
+[%%expect{|
+Line _, characters 23-49:
+Error: Signature mismatch:
+       Modules do not match: sig type t = string end is not included in S
+       Type declarations do not match:
+         type t = string
+       is not included in
+         type t [@@immediate]
+       the first is not an immediate type.
+|}];;
+
+(* Can't use a non-immediate type even if mutually recursive *)
+module E = struct
+  type t = s [@@immediate]
+  and s = string
+end;;
+[%%expect{|
+Line _, characters 2-26:
+Error: Types marked with the immediate attribute must be
+       non-pointer types like int or bool
+|}];;
+(*
+   Implicit unpack allows to omit the signature in (val ...) expressions.
+
+   It also adds (module M : S) and (module M) patterns, relying on
+   implicit (val ...) for the implementation. Such patterns can only
+   be used in function definition, match clauses, and let ... in.
+
+   New: implicit pack is also supported, and you only need to be able
+   to infer the the module type path from the context.
+ *)
+(* ocaml -principal *)
+
+(* Use a module pattern *)
+let sort (type s) (module Set : Set.S with type elt = s) l =
+  Set.elements (List.fold_right Set.add l Set.empty)
+
+(* No real improvement here? *)
+let make_set (type s) cmp : (module Set.S with type elt = s) =
+  (module Set.Make (struct type t = s let compare = cmp end))
+
+(* No type annotation here *)
+let sort_cmp (type s) cmp =
+  sort (module Set.Make (struct type t = s let compare = cmp end))
+
+module type S = sig type t val x : t end;;
+let f (module M : S with type t = int) = M.x;;
+let f (module M : S with type t = 'a) = M.x;; (* Error *)
+let f (type a) (module M : S with type t = a) = M.x;;
+f (module struct type t = int let x = 1 end);;
+
+type 'a s = {s: (module S with type t = 'a)};;
+{s=(module struct type t = int let x = 1 end)};;
+let f {s=(module M)} = M.x;; (* Error *)
+let f (type a) ({s=(module M)} : a s) = M.x;;
+
+type s = {s: (module S with type t = int)};;
+let f {s=(module M)} = M.x;;
+let f {s=(module M)} {s=(module N)} = M.x + N.x;;
+
+module type S = sig val x : int end;;
+let f (module M : S) y (module N : S) = M.x + y + N.x;;
+let m = (module struct let x = 3 end);; (* Error *)
+let m = (module struct let x = 3 end : S);;
+f m 1 m;;
+f m 1 (module struct let x = 2 end);;
+
+let (module M) = m in M.x;;
+let (module M) = m;; (* Error: only allowed in [let .. in] *)
+class c = let (module M) = m in object end;; (* Error again *)
+module M = (val m);;
+
+module type S' = sig val f : int -> int end;;
+(* Even works with recursion, but must be fully explicit *)
+let rec (module M : S') =
+  (module struct let f n = if n <= 0 then 1 else n * M.f (n-1) end : S')
+in M.f 3;;
+
+(* Subtyping *)
+
+module type S = sig type t type u val x : t * u end
+let f (l : (module S with type t = int and type u = bool) list) =
+  (l :> (module S with type u = bool) list)
+
+(* GADTs from the manual *)
+(* the only modification is in to_string *)
+
+module TypEq : sig
+  type ('a, 'b) t
+  val apply: ('a, 'b) t -> 'a -> 'b
+  val refl: ('a, 'a) t
+  val sym: ('a, 'b) t -> ('b, 'a) t
+end = struct
+  type ('a, 'b) t = ('a -> 'b) * ('b -> 'a)
+  let refl = (fun x -> x), (fun x -> x)
+  let apply (f, _) x = f x
+  let sym (f, g) = (g, f)
+end
+
+module rec Typ : sig
+  module type PAIR = sig
+    type t and t1 and t2
+    val eq: (t, t1 * t2) TypEq.t
+    val t1: t1 Typ.typ
+    val t2: t2 Typ.typ
+  end
+
+  type 'a typ =
+    | Int of ('a, int) TypEq.t
+    | String of ('a, string) TypEq.t
+    | Pair of (module PAIR with type t = 'a)
+end = Typ
+
+let int = Typ.Int TypEq.refl
+
+let str = Typ.String TypEq.refl
+
+let pair (type s1) (type s2) t1 t2 =
+  let module P = struct
+    type t = s1 * s2
+    type t1 = s1
+    type t2 = s2
+    let eq = TypEq.refl
+    let t1 = t1
+    let t2 = t2
+  end in
+  Typ.Pair (module P)
+
+open Typ
+let rec to_string: 'a. 'a Typ.typ -> 'a -> string =
+  fun (type s) t x ->
+    match (t : s typ) with
+    | Int eq -> string_of_int (TypEq.apply eq x)
+    | String eq -> Printf.sprintf "%S" (TypEq.apply eq x)
+    | Pair (module P) ->
+        let (x1, x2) = TypEq.apply P.eq x in
+        Printf.sprintf "(%s,%s)" (to_string P.t1 x1) (to_string P.t2 x2)
+
+(* Wrapping maps *)
+module type MapT = sig
+  include Map.S
+  type data
+  type map
+  val of_t : data t -> map
+  val to_t : map -> data t
+end
+
+type ('k,'d,'m) map =
+    (module MapT with type key = 'k and type data = 'd and type map = 'm)
+
+let add (type k) (type d) (type m) (m:(k,d,m) map) x y s =
+   let module M =
+     (val m:MapT with type key = k and type data = d and type map = m) in
+   M.of_t (M.add x y (M.to_t s))
+
+module SSMap = struct
+  include Map.Make(String)
+  type data = string
+  type map = data t
+  let of_t x = x
+  let to_t x = x
+end
+
+let ssmap =
+  (module SSMap:
+   MapT with type key = string and type data = string and type map = SSMap.map)
+;;
+
+let ssmap =
+  (module struct include SSMap end :
+   MapT with type key = string and type data = string and type map = SSMap.map)
+;;
+
+let ssmap =
+  (let module S = struct include SSMap end in (module S) :
+  (module
+   MapT with type key = string and type data = string and type map = SSMap.map))
+;;
+
+let ssmap =
+  (module SSMap: MapT with type key = _ and type data = _ and type map = _)
+;;
+
+let ssmap : (_,_,_) map = (module SSMap);;
+
+add ssmap;;
+open StdLabels
+open MoreLabels
+
+(* Use maps for substitutions and sets for free variables *)
+
+module Subst = Map.Make(struct type t = string let compare = compare end)
+module Names = Set.Make(struct type t = string let compare = compare end)
+
+
+(* Variables are common to lambda and expr *)
+
+type var = [`Var of string]
+
+let subst_var ~subst : var -> _ =
+  function `Var s as x ->
+    try Subst.find s subst
+    with Not_found -> x
+
+let free_var : var -> _ = function `Var s -> Names.singleton s
+
+
+(* The lambda language: free variables, substitutions, and evaluation *)
+
+type 'a lambda = [`Var of string | `Abs of string * 'a | `App of 'a * 'a]
+
+let free_lambda ~free_rec : _ lambda -> _ = function
+    #var as x -> free_var x
+  | `Abs (s, t) -> Names.remove s (free_rec t)
+  | `App (t1, t2) -> Names.union (free_rec t1) (free_rec t2)
+
+let map_lambda ~map_rec : _ lambda -> _ = function
+    #var as x -> x
+  | `Abs (s, t) as l ->
+      let t' = map_rec t in
+      if t == t' then l else `Abs(s, t')
+  | `App (t1, t2) as l ->
+      let t'1 = map_rec t1 and t'2 = map_rec t2 in
+      if t'1 == t1 && t'2 == t2 then l else `App (t'1, t'2)
+
+let next_id =
+  let current = ref 3 in
+  fun () -> incr current; !current
+
+let subst_lambda ~subst_rec ~free ~subst : _ lambda -> _ = function
+    #var as x -> subst_var ~subst x
+  | `Abs(s, t) as l ->
+      let used = free t in
+      let used_expr =
+        Subst.fold subst ~init:[]
+          ~f:(fun ~key ~data acc ->
+                if Names.mem s used then data::acc else acc) in
+      if List.exists used_expr ~f:(fun t -> Names.mem s (free t)) then
+        let name = s ^ string_of_int (next_id ()) in
+        `Abs(name,
+             subst_rec ~subst:(Subst.add ~key:s ~data:(`Var name) subst) t)
+      else
+        map_lambda ~map_rec:(subst_rec ~subst:(Subst.remove s subst)) l
+  | `App _ as l ->
+      map_lambda ~map_rec:(subst_rec ~subst) l
+
+let eval_lambda ~eval_rec ~subst l =
+  match map_lambda ~map_rec:eval_rec l with
+    `App(`Abs(s,t1), t2) ->
+      eval_rec (subst ~subst:(Subst.add ~key:s ~data:t2 Subst.empty) t1)
+  | t -> t
+
+(* Specialized versions to use on lambda *)
+
+let rec free1 x = free_lambda ~free_rec:free1 x
+let rec subst1 ~subst = subst_lambda ~subst_rec:subst1 ~free:free1 ~subst
+let rec eval1 x = eval_lambda ~eval_rec:eval1 ~subst:subst1 x
+
+
+(* The expr language of arithmetic expressions *)
+
+type 'a expr =
+    [`Var of string | `Num of int | `Add of 'a * 'a
+    | `Neg of 'a | `Mult of 'a * 'a]
+
+let free_expr ~free_rec : _ expr -> _ = function
+    #var as x -> free_var x
+  | `Num _ -> Names.empty
+  | `Add(x, y) -> Names.union (free_rec x) (free_rec y)
+  | `Neg x -> free_rec x
+  | `Mult(x, y) -> Names.union (free_rec x) (free_rec y)
+
+(* Here map_expr helps a lot *)
+let map_expr ~map_rec : _ expr -> _ = function
+    #var as x -> x
+  | `Num _ as x -> x
+  | `Add(x, y) as e ->
+      let x' = map_rec x and y' = map_rec y in
+      if x == x' && y == y' then e
+      else `Add(x', y')
+  | `Neg x as e ->
+      let x' = map_rec x in
+      if x == x' then e else `Neg x'
+  | `Mult(x, y) as e ->
+      let x' = map_rec x and y' = map_rec y in
+      if x == x' && y == y' then e
+      else `Mult(x', y')
+
+let subst_expr ~subst_rec ~subst : _ expr -> _ = function
+    #var as x -> subst_var ~subst x
+  | #expr as e -> map_expr ~map_rec:(subst_rec ~subst) e
+
+let eval_expr ~eval_rec e =
+  match map_expr ~map_rec:eval_rec e with
+    `Add(`Num m, `Num n) -> `Num (m+n)
+  | `Neg(`Num n) -> `Num (-n)
+  | `Mult(`Num m, `Num n) -> `Num (m*n)
+  | #expr as e -> e
+
+(* Specialized versions *)
+
+let rec free2 x = free_expr ~free_rec:free2 x
+let rec subst2 ~subst = subst_expr ~subst_rec:subst2 ~subst
+let rec eval2 x = eval_expr ~eval_rec:eval2 x
+
+
+(* The lexpr language, reunion of lambda and expr *)
+
+type lexpr =
+  [ `Var of string | `Abs of string * lexpr | `App of lexpr * lexpr
+  | `Num of int | `Add of lexpr * lexpr | `Neg of lexpr
+  | `Mult of lexpr * lexpr ]
+
+let rec free : lexpr -> _ = function
+    #lambda as x -> free_lambda ~free_rec:free x
+  | #expr as x -> free_expr ~free_rec:free x
+
+let rec subst ~subst:s : lexpr -> _ = function
+    #lambda as x -> subst_lambda ~subst_rec:subst ~subst:s ~free x
+  | #expr as x -> subst_expr ~subst_rec:subst ~subst:s x
+
+let rec eval : lexpr -> _ = function
+    #lambda as x -> eval_lambda ~eval_rec:eval ~subst x
+  | #expr as x -> eval_expr ~eval_rec:eval x
+
+let rec print = function
+  | `Var id -> print_string id
+  | `Abs (id, l) -> print_string ("\ " ^ id ^ " . "); print l
+  | `App (l1, l2) -> print l1; print_string " "; print l2
+  | `Num x -> print_int x
+  | `Add (e1, e2) -> print e1; print_string " + "; print e2
+  | `Neg e -> print_string "-"; print e
+  | `Mult (e1, e2) -> print e1; print_string " * "; print e2
+
+let () =
+  let e1 = eval1 (`App(`Abs("x",`Var"x"), `Var"y")) in
+  let e2 = eval2 (`Add(`Mult(`Num 3,`Neg(`Num 2)), `Var"x")) in
+  let e3 = eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5)) in
+  print e1; print_newline ();
+  print e2; print_newline ();
+  print e3; print_newline ()
+(* Full fledge version, using objects to structure code *)
+
+open StdLabels
+open MoreLabels
+
+(* Use maps for substitutions and sets for free variables *)
+
+module Subst = Map.Make(struct type t = string let compare = compare end)
+module Names = Set.Make(struct type t = string let compare = compare end)
+
+(* To build recursive objects *)
+
+let lazy_fix make =
+  let rec obj () = make (lazy (obj ()) : _ Lazy.t) in
+  obj ()
+
+let (!!) = Lazy.force
+
+(* The basic operations *)
+
+class type ['a, 'b] ops =
+  object
+    method free : x:'b -> ?y:'c -> Names.t
+    method subst : sub:'a Subst.t -> 'b -> 'a
+    method eval : 'b -> 'a
+  end
+
+(* Variables are common to lambda and expr *)
+
+type var = [`Var of string]
+
+class ['a] var_ops = object (self : ('a, var) #ops)
+  constraint 'a = [> var]
+  method subst ~sub (`Var s as x) =
+    try Subst.find s sub with Not_found -> x
+  method free (`Var s) =
+    Names.singleton s
+  method eval (#var as v) = v
+end
+
+(* The lambda language: free variables, substitutions, and evaluation *)
+
+type 'a lambda = [`Var of string | `Abs of string * 'a | `App of 'a * 'a]
+
+let next_id =
+  let current = ref 3 in
+  fun () -> incr current; !current
+
+class ['a] lambda_ops (ops : ('a,'a) #ops Lazy.t) =
+  let var : 'a var_ops = new var_ops
+  and free = lazy !!ops#free
+  and subst = lazy !!ops#subst
+  and eval = lazy !!ops#eval in
+  object (self : ('a, 'a lambda) #ops)
+    constraint 'a = [> 'a lambda]
+    method free = function
+        #var as x -> var#free x
+      | `Abs (s, t) -> Names.remove s (!!free t)
+      | `App (t1, t2) -> Names.union (!!free t1) (!!free t2)
+
+    method map ~f = function
+        #var as x -> x
+      | `Abs (s, t) as l ->
+          let t' = f t in
+          if t == t' then l else `Abs(s, t')
+      | `App (t1, t2) as l ->
+          let t'1 = f t1 and t'2 = f t2 in
+          if t'1 == t1 && t'2 == t2 then l else `App (t'1, t'2)
+
+    method subst ~sub = function
+        #var as x -> var#subst ~sub x
+      | `Abs(s, t) as l ->
+          let used = !!free t in
+          let used_expr =
+            Subst.fold sub ~init:[]
+              ~f:(fun ~key ~data acc ->
+                if Names.mem s used then data::acc else acc) in
+          if List.exists used_expr ~f:(fun t -> Names.mem s (!!free t)) then
+            let name = s ^ string_of_int (next_id ()) in
+            `Abs(name,
+                 !!subst ~sub:(Subst.add ~key:s ~data:(`Var name) sub) t)
+          else
+            self#map ~f:(!!subst ~sub:(Subst.remove s sub)) l
+      | `App _ as l ->
+          self#map ~f:(!!subst ~sub) l
+
+    method eval l =
+      match self#map ~f:!!eval l with
+        `App(`Abs(s,t1), t2) ->
+          !!eval (!!subst ~sub:(Subst.add ~key:s ~data:t2 Subst.empty) t1)
+      | t -> t
+end
+
+(* Operations specialized to lambda *)
+
+let lambda = lazy_fix (new lambda_ops)
+
+(* The expr language of arithmetic expressions *)
+
+type 'a expr =
+    [ `Var of string | `Num of int | `Add of 'a * 'a
+    | `Neg of 'a | `Mult of 'a * 'a]
+
+class ['a] expr_ops (ops : ('a,'a) #ops Lazy.t) =
+  let var : 'a var_ops = new var_ops
+  and free = lazy !!ops#free
+  and subst = lazy !!ops#subst
+  and eval = lazy !!ops#eval in
+  object (self : ('a, 'a expr) #ops)
+    constraint 'a = [> 'a expr]
+    method free = function
+        #var as x -> var#free x
+      | `Num _ -> Names.empty
+      | `Add(x, y) -> Names.union (!!free x) (!!free y)
+      | `Neg x -> !!free x
+      | `Mult(x, y) -> Names.union (!!free x) (!!free y)
+
+    method map ~f = function
+        #var as x -> x
+      | `Num _ as x -> x
+      | `Add(x, y) as e ->
+          let x' = f x and y' = f y in
+          if x == x' && y == y' then e
+          else `Add(x', y')
+      | `Neg x as e ->
+          let x' = f x in
+          if x == x' then e else `Neg x'
+      | `Mult(x, y) as e ->
+          let x' = f x and y' = f y in
+          if x == x' && y == y' then e
+          else `Mult(x', y')
+
+    method subst ~sub = function
+        #var as x -> var#subst ~sub x
+      | #expr as e -> self#map ~f:(!!subst ~sub) e
+
+    method eval (#expr as e) =
+      match self#map ~f:!!eval e with
+        `Add(`Num m, `Num n) -> `Num (m+n)
+      | `Neg(`Num n) -> `Num (-n)
+      | `Mult(`Num m, `Num n) -> `Num (m*n)
+      | e -> e
+  end
+
+(* Specialized versions *)
+
+let expr = lazy_fix (new expr_ops)
+
+(* The lexpr language, reunion of lambda and expr *)
+
+type 'a lexpr = [ 'a lambda | 'a expr ]
+
+class ['a] lexpr_ops (ops : ('a,'a) #ops Lazy.t) =
+  let lambda = new lambda_ops ops in
+  let expr = new expr_ops ops in
+  object (self : ('a, 'a lexpr) #ops)
+    constraint 'a = [> 'a lexpr]
+    method free = function
+        #lambda as x -> lambda#free x
+      | #expr as x -> expr#free x
+
+    method subst ~sub = function
+        #lambda as x -> lambda#subst ~sub x
+      | #expr as x -> expr#subst ~sub x
+
+    method eval = function
+        #lambda as x -> lambda#eval x
+      | #expr as x -> expr#eval x
+end
+
+let lexpr = lazy_fix (new lexpr_ops)
+
+let rec print = function
+  | `Var id -> print_string id
+  | `Abs (id, l) -> print_string ("\ " ^ id ^ " . "); print l
+  | `App (l1, l2) -> print l1; print_string " "; print l2
+  | `Num x -> print_int x
+  | `Add (e1, e2) -> print e1; print_string " + "; print e2
+  | `Neg e -> print_string "-"; print e
+  | `Mult (e1, e2) -> print e1; print_string " * "; print e2
+
+let () =
+  let e1 = lambda#eval (`App(`Abs("x",`Var"x"), `Var"y")) in
+  let e2 = expr#eval (`Add(`Mult(`Num 3,`Neg(`Num 2)), `Var"x")) in
+  let e3 =
+    lexpr#eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5))
+  in
+  print e1; print_newline ();
+  print e2; print_newline ();
+  print e3; print_newline ()
+(* Full fledge version, using objects to structure code *)
+
+open StdLabels
+open MoreLabels
+
+(* Use maps for substitutions and sets for free variables *)
+
+module Subst = Map.Make(struct type t = string let compare = compare end)
+module Names = Set.Make(struct type t = string let compare = compare end)
+
+(* To build recursive objects *)
+
+let lazy_fix make =
+  let rec obj () = make (lazy (obj ()) : _ Lazy.t) in
+  obj ()
+
+let (!!) = Lazy.force
+
+(* The basic operations *)
+
+class type ['a, 'b] ops =
+  object
+    method free : 'b -> Names.t
+    method subst : sub:'a Subst.t -> 'b -> 'a
+    method eval : 'b -> 'a
+  end
+
+(* Variables are common to lambda and expr *)
+
+type var = [`Var of string]
+
+let var = object (self : ([>var], var) #ops)
+  method subst ~sub (`Var s as x) =
+    try Subst.find s sub with Not_found -> x
+  method free (`Var s) =
+    Names.singleton s
+  method eval (#var as v) = v
+end
+
+(* The lambda language: free variables, substitutions, and evaluation *)
+
+type 'a lambda = [`Var of string | `Abs of string * 'a | `App of 'a * 'a]
+
+let next_id =
+  let current = ref 3 in
+  fun () -> incr current; !current
+
+let lambda_ops (ops : ('a,'a) #ops Lazy.t) =
+  let free = lazy !!ops#free
+  and subst = lazy !!ops#subst
+  and eval = lazy !!ops#eval in
+  object (self : ([> 'a lambda], 'a lambda) #ops)
+    method free = function
+        #var as x -> var#free x
+      | `Abs (s, t) -> Names.remove s (!!free t)
+      | `App (t1, t2) -> Names.union (!!free t1) (!!free t2)
+
+    method private map ~f = function
+        #var as x -> x
+      | `Abs (s, t) as l ->
+          let t' = f t in
+          if t == t' then l else `Abs(s, t')
+      | `App (t1, t2) as l ->
+          let t'1 = f t1 and t'2 = f t2 in
+          if t'1 == t1 && t'2 == t2 then l else `App (t'1, t'2)
+
+    method subst ~sub = function
+        #var as x -> var#subst ~sub x
+      | `Abs(s, t) as l ->
+          let used = !!free t in
+          let used_expr =
+            Subst.fold sub ~init:[]
+              ~f:(fun ~key ~data acc ->
+                if Names.mem s used then data::acc else acc) in
+          if List.exists used_expr ~f:(fun t -> Names.mem s (!!free t)) then
+            let name = s ^ string_of_int (next_id ()) in
+            `Abs(name,
+                 !!subst ~sub:(Subst.add ~key:s ~data:(`Var name) sub) t)
+          else
+            self#map ~f:(!!subst ~sub:(Subst.remove s sub)) l
+      | `App _ as l ->
+          self#map ~f:(!!subst ~sub) l
+
+    method eval l =
+      match self#map ~f:!!eval l with
+        `App(`Abs(s,t1), t2) ->
+          !!eval (!!subst ~sub:(Subst.add ~key:s ~data:t2 Subst.empty) t1)
+      | t -> t
+end
+
+(* Operations specialized to lambda *)
+
+let lambda = lazy_fix lambda_ops
+
+(* The expr language of arithmetic expressions *)
+
+type 'a expr =
+    [ `Var of string | `Num of int | `Add of 'a * 'a
+    | `Neg of 'a | `Mult of 'a * 'a]
+
+let expr_ops (ops : ('a,'a) #ops Lazy.t) =
+  let free = lazy !!ops#free
+  and subst = lazy !!ops#subst
+  and eval = lazy !!ops#eval in
+  object (self : ([> 'a expr], 'a expr) #ops)
+    method free = function
+        #var as x -> var#free x
+      | `Num _ -> Names.empty
+      | `Add(x, y) -> Names.union (!!free x) (!!free y)
+      | `Neg x -> !!free x
+      | `Mult(x, y) -> Names.union (!!free x) (!!free y)
+
+    method private map ~f = function
+        #var as x -> x
+      | `Num _ as x -> x
+      | `Add(x, y) as e ->
+          let x' = f x and y' = f y in
+          if x == x' && y == y' then e
+          else `Add(x', y')
+      | `Neg x as e ->
+          let x' = f x in
+          if x == x' then e else `Neg x'
+      | `Mult(x, y) as e ->
+          let x' = f x and y' = f y in
+          if x == x' && y == y' then e
+          else `Mult(x', y')
+
+    method subst ~sub = function
+        #var as x -> var#subst ~sub x
+      | #expr as e -> self#map ~f:(!!subst ~sub) e
+
+    method eval (#expr as e) =
+      match self#map ~f:!!eval e with
+        `Add(`Num m, `Num n) -> `Num (m+n)
+      | `Neg(`Num n) -> `Num (-n)
+      | `Mult(`Num m, `Num n) -> `Num (m*n)
+      | e -> e
+  end
+
+(* Specialized versions *)
+
+let expr = lazy_fix expr_ops
+
+(* The lexpr language, reunion of lambda and expr *)
+
+type 'a lexpr = [ 'a lambda | 'a expr ]
+
+let lexpr_ops (ops : ('a,'a) #ops Lazy.t) =
+  let lambda = lambda_ops ops in
+  let expr = expr_ops ops in
+  object (self : ([> 'a lexpr], 'a lexpr) #ops)
+    method free = function
+        #lambda as x -> lambda#free x
+      | #expr as x -> expr#free x
+
+    method subst ~sub = function
+        #lambda as x -> lambda#subst ~sub x
+      | #expr as x -> expr#subst ~sub x
+
+    method eval = function
+        #lambda as x -> lambda#eval x
+      | #expr as x -> expr#eval x
+end
+
+let lexpr = lazy_fix lexpr_ops
+
+let rec print = function
+  | `Var id -> print_string id
+  | `Abs (id, l) -> print_string ("\ " ^ id ^ " . "); print l
+  | `App (l1, l2) -> print l1; print_string " "; print l2
+  | `Num x -> print_int x
+  | `Add (e1, e2) -> print e1; print_string " + "; print e2
+  | `Neg e -> print_string "-"; print e
+  | `Mult (e1, e2) -> print e1; print_string " * "; print e2
+
+let () =
+  let e1 = lambda#eval (`App(`Abs("x",`Var"x"), `Var"y")) in
+  let e2 = expr#eval (`Add(`Mult(`Num 3,`Neg(`Num 2)), `Var"x")) in
+  let e3 =
+    lexpr#eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5))
+  in
+  print e1; print_newline ();
+  print e2; print_newline ();
+  print e3; print_newline ()
+type sexp = A of string | L of sexp list
+type 'a t = 'a array
+let _ = fun (_ : 'a t)  -> ()
+
+let array_of_sexp _ _ = [| |]
+let sexp_of_array _ _ = A "foo"
+let sexp_of_int _ = A "42"
+let int_of_sexp _ = 42
+
+let t_of_sexp : 'a . (sexp -> 'a) -> sexp -> 'a t=
+  let _tp_loc = "core_array.ml.t" in
+  fun _of_a  -> fun t  -> (array_of_sexp _of_a) t
+let _ = t_of_sexp
+let sexp_of_t : 'a . ('a -> sexp) -> 'a t -> sexp=
+  fun _of_a  -> fun v  -> (sexp_of_array _of_a) v
+let _ = sexp_of_t
+module T =
+  struct
+    module Int =
+      struct
+        type t_ = int array
+        let _ = fun (_ : t_)  -> ()
+
+        let t__of_sexp: sexp -> t_ =
+          let _tp_loc = "core_array.ml.T.Int.t_" in
+          fun t  -> (array_of_sexp int_of_sexp) t
+        let _ = t__of_sexp
+        let sexp_of_t_: t_ -> sexp =
+          fun v  -> (sexp_of_array sexp_of_int) v
+        let _ = sexp_of_t_
+      end
+  end
+module type Permissioned  =
+  sig
+    type ('a,-'perms) t
+  end
+module Permissioned :
+  sig
+    type ('a,-'perms) t
+    include
+      sig
+        val t_of_sexp :
+          (sexp -> 'a) ->
+            (sexp -> 'perms) -> sexp -> ('a,'perms) t
+        val sexp_of_t :
+          ('a -> sexp) ->
+            ('perms -> sexp) -> ('a,'perms) t -> sexp
+      end
+    module Int :
+    sig
+      type nonrec -'perms t = (int,'perms) t
+      include
+        sig
+          val t_of_sexp :
+            (sexp -> 'perms) -> sexp -> 'perms t
+          val sexp_of_t :
+            ('perms -> sexp) -> 'perms t -> sexp
+        end
+    end
+  end =
+  struct
+    type ('a,-'perms) t = 'a array
+    let _ = fun (_ : ('a,'perms) t)  -> ()
+
+    let t_of_sexp :
+      'a 'perms .
+        (sexp -> 'a) ->
+          (sexp -> 'perms) -> sexp -> ('a,'perms) t=
+      let _tp_loc = "core_array.ml.Permissioned.t" in
+      fun _of_a  -> fun _of_perms  -> fun t  -> (array_of_sexp _of_a) t
+    let _ = t_of_sexp
+    let sexp_of_t :
+      'a 'perms .
+        ('a -> sexp) ->
+          ('perms -> sexp) -> ('a,'perms) t -> sexp=
+      fun _of_a  -> fun _of_perms  -> fun v  -> (sexp_of_array _of_a) v
+    let _ = sexp_of_t
+    module Int =
+      struct
+        include T.Int
+        type -'perms t = t_
+        let _ = fun (_ : 'perms t)  -> ()
+
+        let t_of_sexp :
+          'perms . (sexp -> 'perms) -> sexp -> 'perms t=
+          let _tp_loc = "core_array.ml.Permissioned.Int.t" in
+          fun _of_perms  -> fun t  -> t__of_sexp t
+        let _ = t_of_sexp
+        let sexp_of_t :
+          'perms . ('perms -> sexp) -> 'perms t -> sexp=
+          fun _of_perms  -> fun v  -> sexp_of_t_ v
+        let _ = sexp_of_t
+      end
+  end
+type 'a  foo = {x: 'a; y: int}
+let r = {{x = 0; y = 0} with x = 0}
+let r' : string foo = r
+external foo : int = "%ignore";;
+let _ = foo ();;
+type 'a t = [`A of 'a t t] as 'a;; (* fails *)
+
+type 'a t = [`A of 'a t t];; (* fails *)
+
+type 'a t = [`A of 'a t t] constraint 'a = 'a t;;
+
+type 'a t = [`A of 'a t] constraint 'a = 'a t;;
+
+type 'a t = [`A of 'a] as 'a;;
+
+type 'a v = [`A of u v] constraint 'a = t and t = u and u = t;; (* fails *)
+
+type 'a t = 'a;;
+let f (x : 'a t as 'a) = ();; (* fails *)
+
+let f (x : 'a t) (y : 'a) = x = y;;
+
+(* PR#6505 *)
+module type PR6505 = sig
+  type 'o is_an_object = < .. > as 'o
+  and 'o abs constraint 'o = 'o is_an_object
+  val abs : 'o is_an_object -> 'o abs
+  val unabs : 'o abs -> 'o
+end;; (* fails *)
+(* PR#5835 *)
+let f ~x = x + 1;;
+f ?x:0;;
+
+(* PR#6352 *)
+let foo (f : unit -> unit) = ();;
+let g ?x () = ();;
+foo ((); g);;
+
+(* PR#5748 *)
+foo (fun ?opt () -> ()) ;; (* fails *)
+(* PR#5907 *)
+
+type 'a t = 'a;;
+let f (g : 'a list -> 'a t -> 'a) s = g s s;;
+let f (g : 'a * 'b -> 'a t -> 'a) s = g s s;;
+type ab = [ `A | `B ];;
+let f (x : [`A]) = match x with #ab -> 1;;
+let f x = ignore (match x with #ab -> 1); ignore (x : [`A]);;
+let f x = ignore (match x with `A|`B -> 1); ignore (x : [`A]);;
+
+let f (x : [< `A | `B]) = match x with `A | `B | `C -> 0;; (* warn *)
+let f (x : [`A | `B]) = match x with `A | `B | `C -> 0;; (* fail *)
+
+(* PR#6787 *)
+let revapply x f = f x;;
+
+let f x (g : [< `Foo]) =
+  let y = `Bar x, g in
+  revapply y (fun ((`Bar i), _) -> i);;
+(* f : 'a -> [< `Foo ] -> 'a *)
+
+let rec x = [| x |]; 1.;;
+
+let rec x = let u = [|y|] in 10. and y = 1.;;
+type 'a t
+type a
+
+let f : < .. > t -> unit = fun _ -> ();;
+
+let g : [< `b] t -> unit = fun _ -> ();;
+
+let h : [> `b] t -> unit = fun _ -> ();;
+
+let _ = fun (x : a t) -> f x;;
+
+let _ = fun (x : a t) -> g x;;
+
+let _ = fun (x : a t) -> h x;;
+(* PR#7012 *)
+
+type t = [ 'A_name | `Hi ];;
+
+let f (x:'id_arg) = x;;
+
+let f (x:'Id_arg) = x;;
+(* undefined labels *)
+type t = {x:int;y:int};;
+{x=3;z=2};;
+fun {x=3;z=2} -> ();;
+
+(* mixed labels *)
+{x=3; contents=2};;
+
+(* private types *)
+type u = private {mutable u:int};;
+{u=3};;
+fun x -> x.u <- 3;;
+
+(* Punning and abbreviations *)
+module M = struct
+  type t = {x: int; y: int}
+end;;
+
+let f {M.x; y} = x+y;;
+let r = {M.x=1; y=2};;
+let z = f r;;
+
+(* messages *)
+type foo = { mutable y:int };;
+let f (r: int) = r.y <- 3;;
+
+(* bugs *)
+type foo = { y: int; z: int };;
+type bar = { x: int };;
+let f (r: bar) = ({ r with z = 3 } : foo)
+
+type foo = { x: int };;
+let r : foo = { ZZZ.x = 2 };;
+
+(ZZZ.X : int option);;
+
+(* PR#5865 *)
+let f (x : Complex.t) = x.Complex.z;;
+(* PR#6394 *)
+
+module rec X : sig
+ type t = int * bool
+end = struct
+ type t = A | B
+ let f = function A | B -> 0
+end;;
+(* PR#6768 *)
+
+type _ prod = Prod : ('a * 'y) prod;;
+
+let f : type t. t prod -> _ = function Prod ->
+  let module M =
+    struct
+      type d = d * d
+    end
+  in ()
+;;
+let (a : M.a) = 2
+let (b : M.b) = 2
+let _ = A.a = B.b
+module Std = struct module Hash = Hashtbl end;;
+
+open Std;;
+module Hash1 : module type of Hash = Hash;;
+module Hash2 : sig include (module type of Hash) end = Hash;;
+let f1 (x : (_,_) Hash1.t) = (x : (_,_) Hashtbl.t);;
+let f2 (x : (_,_) Hash2.t) = (x : (_,_) Hashtbl.t);;
+
+(* Another case, not using include *)
+
+module Std2 = struct module M = struct type t end end;;
+module Std' = Std2;;
+module M' : module type of Std'.M = Std2.M;;
+let f3 (x : M'.t) = (x : Std2.M.t);;
+
+(* original report required Core_kernel:
+module type S = sig
+open Core_kernel.Std
+
+module Hashtbl1 : module type of Hashtbl
+module Hashtbl2 : sig
+  include (module type of Hashtbl)
+end
+
+module Coverage : Core_kernel.Std.Hashable
+
+type types = unit constraint 'a Coverage.Table.t = (Coverage.t, 'a) Hashtbl1.t
+type doesnt_type = unit
+  constraint 'a Coverage.Table.t = (Coverage.t, 'a) Hashtbl2.t
+end
+*)
+module type INCLUDING = sig
+  include module type of List
+  include module type of ListLabels
+end
+
+module Including_typed: INCLUDING = struct
+  include List
+  include ListLabels
+end
+module X=struct
+  module type SIG=sig type t=int val x:t end
+  module F(Y:SIG) : SIG = struct type t=Y.t let x=Y.x end
+end;;
+module DUMMY=struct type t=int let x=2 end;;
+let x = (3 : X.F(DUMMY).t);;
+
+module X2=struct
+  module type SIG=sig type t=int val x:t end
+  module F(Y:SIG)(Z:SIG) = struct
+    type t=Y.t
+    let x=Y.x
+    type t'=Z.t
+    let x'=Z.x
+  end
+end;;
+let x = (3 : X2.F(DUMMY)(DUMMY).t);;
+let x = (3 : X2.F(DUMMY)(DUMMY).t');;
+module F (M : sig
+    type 'a t
+    type 'a u = string
+    val f : unit -> _ u t
+  end) = struct
+    let t = M.f ()
+  end
+type 't a = [ `A ]
+type 't wrap = 't constraint 't = [> 't wrap a ]
+type t = t a wrap
+
+module T = struct
+  let foo : 't wrap -> 't wrap -> unit = fun _ _ -> ()
+  let bar : ('a a wrap as 'a) = `A
+end
+
+module Good : sig
+  val bar: t
+  val foo: t -> t -> unit
+end = T
+
+module Bad : sig
+  val foo: t -> t -> unit
+  val bar: t
+end = T
+module M : sig
+  module type T
+  module F (X : T) : sig end
+end = struct
+  module type T = sig end
+  module F (X : T) = struct end
+end
+
+module type T = M.T
+
+module F : functor (X : T) -> sig end = M.F
+module type S = sig type t = { a : int; b : int; } end;;
+let f (module M : S with type t = int) = { M.a = 0 };;
+let flag = ref false
+module F(S : sig module type T end) (A : S.T) (B : S.T) =
+struct
+  module X = (val if !flag then (module A) else (module B) : S.T)
+end
+
+(* If the above were accepted, one could break soundness *)
+module type S = sig type t val x : t end
+module Float = struct type t = float let x = 0.0 end
+module Int = struct type t = int let x = 0 end
+
+module M = F(struct module type T = S end)
+
+let () = flag := false
+module M1 = M(Float)(Int)
+
+let () = flag := true
+module M2 = M(Float)(Int)
+
+let _ = [| M2.X.x; M1.X.x |]
+module type PR6513 = sig
+module type S = sig type u end
+
+module type T = sig
+  type 'a wrap
+  type uri
+end
+
+module Make: functor (Html5 : T with type 'a wrap = 'a) ->
+  S with type u = < foo : Html5.uri >
+end
+
+(* Requires -package tyxml
+module type PR6513_orig = sig
+module type S =
+sig
+        type t
+        type u
+end
+
+module Make: functor (Html5: Html5_sigs.T
+                             with type 'a Xml.wrap = 'a and
+                             type 'a wrap = 'a and
+                             type 'a list_wrap = 'a list)
+                     -> S with type t = Html5_types.div Html5.elt and
+                               type u = < foo: Html5.uri >
+end
+*)
+module type S = sig
+  include Set.S
+  module E : sig val x : int end
+end
+
+module Make(O : Set.OrderedType) : S with type elt = O.t =
+  struct
+    include Set.Make(O)
+    module E = struct let x = 1 end
+  end
+
+module rec A : Set.OrderedType = struct
+ type t = int
+  let compare = Pervasives.compare
+end
+and B : S = struct
+ module C = Make(A)
+ include C
+end
+module type S = sig
+  module type T
+  module X : T
+end
+
+module F (X : S) = X.X
+
+module M = struct
+  module type T = sig type t end
+  module X = struct type t = int end
+end
+
+type t = F(M).t
+module Common0 =
+ struct
+   type msg = Msg
+
+   let handle_msg = ref (function _ -> failwith "Unable to handle message")
+   let extend_handle f =
+   let old = !handle_msg in
+   handle_msg := f old
+
+   let q : _ Queue.t = Queue.create ()
+   let add msg = Queue.add msg q
+   let handle_queue_messages () = Queue.iter !handle_msg q
+ end
+
+let q' : Common0.msg Queue.t = Common0.q
+
+module Common =
+ struct
+   type msg = ..
+
+   let handle_msg = ref (function _ -> failwith "Unable to handle message")
+   let extend_handle f =
+   let old = !handle_msg in
+   handle_msg := f old
+
+   let q : _ Queue.t = Queue.create ()
+   let add msg = Queue.add msg q
+   let handle_queue_messages () = Queue.iter !handle_msg q
+ end
+
+module M1 =
+ struct
+   type Common.msg += Reload of string | Alert of string
+
+   let handle fallback = function
+     Reload s -> print_endline ("Reload "^s)
+   | Alert s -> print_endline ("Alert "^s)
+   | x -> fallback x
+
+   let () = Common.extend_handle handle
+   let () = Common.add (Reload "config.file")
+   let () = Common.add (Alert "Initialisation done")
+ end
+let should_reject =
+  let table = Hashtbl.create 1 in
+  fun x y -> Hashtbl.add table x y
+type 'a t = 'a option
+let is_some = function
+  | None -> false
+  | Some _ -> true
+
+let should_accept ?x () = is_some x
+include struct
+  let foo `Test = ()
+  let wrap f `Test = f
+  let bar = wrap ()
+end
+let f () =
+   let module S = String in
+   let module N = Map.Make(S) in
+   N.add "sum" 41 N.empty;;
+module X = struct module Y = struct module type S = sig type t end end end
+
+(* open X  (* works! *) *)
+module Y = X.Y
+
+type 'a arg_t = 'at constraint 'a = (module Y.S with type t = 'at)
+type t = (module X.Y.S with type t = unit)
+
+let f (x : t arg_t) = ()
+
+let () = f ()
+module type S =
+sig
+  type a
+  type b
+end
+module Foo
+    (Bar : S with type a = private [> `A])
+    (Baz : S with type b = private < b : Bar.b ; .. >) =
+struct
+end
+module A = struct
+ module type A_S = sig
+ end
+
+ type t = (module A_S)
+end
+
+module type S = sig type t end
+
+let f (type a) (module X : S with type t = a) = ()
+
+let _ = f (module A) (* ok *)
+
+module A_annotated_alias : S with type t = (module A.A_S) = A
+
+let _ = f (module A_annotated_alias) (* ok *)
+let _ = f (module A_annotated_alias : S with type t = (module A.A_S)) (* ok *)
+
+module A_alias = A
+module A_alias_expanded = struct include A_alias end
+
+let _ = f (module A_alias_expanded : S with type t = (module A.A_S)) (* ok *)
+let _ = f (module A_alias_expanded) (* ok *)
+
+let _ = f (module A_alias : S with type t = (module A.A_S)) (* doesn't type *)
+let _ = f (module A_alias) (* doesn't type either *)
+module Foo
+ (Bar : sig type a = private [> `A ] end)
+ (Baz : module type of struct include Bar end) =
+struct
+end
+module Bazoinks = struct type a = [ `A ] end
+module Bug = Foo(Bazoinks)(Bazoinks)
+(* PR#6992, reported by Stephen Dolan *)
+
+type (_, _) eq = Eq : ('a, 'a) eq
+let cast : type a b . (a, b) eq -> a -> b = fun Eq x -> x
+
+module Fix (F : sig type 'a f end) = struct
+  type 'a fix = ('a, 'a F.f) eq
+  let uniq (type a) (type b) (Eq : a fix) (Eq : b fix) : (a, b) eq = Eq
+end
+
+(* This would allow:
+module FixId = Fix (struct type 'a f = 'a end)
+ let bad : (int, string) eq = FixId.uniq Eq Eq
+ let _ = Printf.printf "Oh dear: %s" (cast bad 42)
+*)
+module M = struct
+ module type S = sig type a val v : a end
+ type 'a s = (module S with type a = 'a)
+end
+
+module B = struct
+ class type a = object method a : 'a. 'a M.s -> 'a end
+end
+
+module M' = M
+module B' = B
+
+class b : B.a = object
+ method a : 'a. 'a M.s -> 'a = fun (type a) ((module X) : (module M.S with type
+a = a)) -> X.v
+end
+
+class b' : B.a = object
+ method a : 'a. 'a M'.s -> 'a = fun (type a) ((module X) : (module M'.S with
+type a = a)) -> X.v
+end
+module type FOO = sig type t end
+module type BAR =
+sig
+  (* Works: module rec A : (sig include FOO with type t = < b:B.t > end) *)
+  module rec A : (FOO with type t = < b:B.t >)
+         and B : FOO
+end
+module A = struct module type S module S = struct end end
+module F (_ : sig end) = struct module type S module S = A.S end
+module M = struct end
+module N = M
+module G (X : F(N).S) : A.S = X
+module F (_ : sig end) = struct module type S end
+module M = struct end
+module N = M
+module G (X : F(N).S) : F(M).S = X
+module M :  sig
+  type make_dec
+  val add_dec: make_dec -> unit
+end = struct
+  type u
+
+  module Fast: sig
+    type 'd t
+    val create: unit -> 'd t
+    module type S = sig
+      module Data: sig type t end
+      val key: Data.t t
+    end
+    module Register (D:S): sig end
+    val attach: 'd t -> 'd -> unit
+  end = struct
+    type 'd t = unit
+    let create () = ()
+    module type S = sig
+      module Data: sig type t end
+      val key: Data.t t
+    end
+    module Register (D:S) = struct end
+    let attach _ _ = ()
+  end
+
+  type make_dec
+
+  module Dem = struct
+    module Data = struct
+      type t = make_dec
+    end
+    let key = Fast.create ()
+  end
+
+  module EDem = Fast.Register(Dem)
+
+  let add_dec dec =
+    Fast.attach Dem.key dec
+end
+
+(* simpler version *)
+
+module Simple = struct
+  type 'a t
+  module type S = sig
+    module Data: sig type t end
+    val key: Data.t t
+  end
+  module Register (D:S) = struct let key = D.key end
+  module M = struct
+    module Data = struct type t = int end
+    let key : _ t = Obj.magic ()
+  end
+end;;
+module EM = Simple.Register(Simple.M);;
+Simple.M.key;;
+
+module Simple2 = struct
+  type 'a t
+  module type S = sig
+    module Data: sig type t end
+    val key: Data.t t
+  end
+  module M = struct
+    module Data = struct type t = int end
+    let key : _ t = Obj.magic ()
+  end
+  module Register (D:S) = struct let key = D.key end
+  module EM = Simple.Register(Simple.M)
+  let k : M.Data.t t = M.key
+end;;
+module rec M
+    : sig external f : int -> int = "%identity" end
+    = struct external f : int -> int = "%identity" end
+(* with module *)
+
+module type S = sig type t and s = t end;;
+module type S' = S with type t := int;;
+
+module type S = sig module rec M : sig end and N : sig end end;;
+module type S' = S with module M := String;;
+
+(* with module type *)
+(*
+module type S = sig module type T module F(X:T) : T end;;
+module type T0 = sig type t end;;
+module type S1 = S with module type T = T0;;
+module type S2 = S with module type T := T0;;
+module type S3 = S with module type T := sig type t = int end;;
+module H = struct
+  include (Hashtbl : module type of Hashtbl with
+           type statistics := Hashtbl.statistics
+           and module type S := Hashtbl.S
+           and module Make := Hashtbl.Make
+           and module MakeSeeded := Hashtbl.MakeSeeded
+           and module type SeededS := Hashtbl.SeededS
+           and module type HashedType := Hashtbl.HashedType
+           and module type SeededHashedType := Hashtbl.SeededHashedType)
+end;;
+*)
+
+(* A subtle problem appearing with -principal *)
+type -'a t
+class type c = object method m : [ `A ] t end;;
+module M : sig val v : (#c as 'a) -> 'a end =
+  struct let v x = ignore (x :> c); x end;;
+
+(* PR#4838 *)
+
+let id = let module M = struct end in fun x -> x;;
+
+(* PR#4511 *)
+
+let ko = let module M = struct end in fun _ -> ();;
+
+(* PR#5993 *)
+
+module M : sig type -'a t = private int end =
+  struct type +'a t = private int end
+;;
+
+(* PR#6005 *)
+
+module type A = sig type t = X of int end;;
+type u = X of bool;;
+module type B = A with type t = u;; (* fail *)
+
+(* PR#5815 *)
+(* ---> duplicated exception name is now an error *)
+
+module type S = sig exception Foo of int  exception Foo of bool end;;
+
+(* PR#6410 *)
+
+module F(X : sig end) = struct let x = 3 end;;
+F.x;; (* fail *)
+module C = Char;;
+C.chr 66;;
+
+module C' : module type of Char = C;;
+C'.chr 66;;
+
+module C3 = struct include Char end;;
+C3.chr 66;;
+
+let f x = let module M = struct module L = List end in M.L.length x;;
+let g x = let module L = List in L.length (L.map succ x);;
+
+module F(X:sig end) = Char;;
+module C4 = F(struct end);;
+C4.chr 66;;
+
+module G(X:sig end) = struct module M = X end;; (* does not alias X *)
+module M = G(struct end);;
+
+module M' = struct
+  module N = struct let x = 1 end
+  module N' = N
+end;;
+M'.N'.x;;
+
+module M'' : sig module N' : sig val x : int end end = M';;
+M''.N'.x;;
+module M2 = struct include M' end;;
+module M3 : sig module N' : sig val x : int end end = struct include M' end;;
+M3.N'.x;;
+module M3' : sig module N' : sig val x : int end end = M2;;
+M3'.N'.x;;
+
+module M4 : sig module N' : sig val x : int end end = struct
+  module N = struct let x = 1 end
+  module N' = N
+end;;
+M4.N'.x;;
+
+module F(X:sig end) = struct
+  module N = struct let x = 1 end
+  module N' = N
+end;;
+module G : functor(X:sig end) -> sig module N' : sig val x : int end end = F;;
+module M5 = G(struct end);;
+M5.N'.x;;
+
+module M = struct
+  module D = struct let y = 3 end
+  module N = struct let x = 1 end
+  module N' = N
+end;;
+
+module M1 : sig module N : sig val x : int end module N' = N end = M;;
+M1.N'.x;;
+module M2 : sig module N' : sig val x : int end end =
+  (M : sig module N : sig val x : int end module N' = N end);;
+M2.N'.x;;
+
+open M;;
+N'.x;;
+
+module M = struct
+  module C = Char
+  module C' = C
+end;;
+module M1
+  : sig module C : sig val escaped : char -> string end module C' = C end
+  = M;; (* sound, but should probably fail *)
+M1.C'.escaped 'A';;
+module M2 : sig module C' : sig val chr : int -> char end end =
+  (M : sig module C : sig val chr : int -> char end module C' = C end);;
+M2.C'.chr 66;;
+
+StdLabels.List.map;;
+
+module Q = Queue;;
+exception QE = Q.Empty;;
+try Q.pop (Q.create ()) with QE -> "Ok";;
+
+module type Complex = module type of Complex with type t = Complex.t;;
+module M : sig module C : Complex end = struct module C = Complex end;;
+
+module C = Complex;;
+C.one.Complex.re;;
+include C;;
+
+module F(X:sig module C = Char end) = struct module C = X.C end;;
+
+(* Applicative functors *)
+module S = String
+module StringSet = Set.Make(String)
+module SSet = Set.Make(S);;
+let f (x : StringSet.t) = (x : SSet.t);;
+
+(* Also using include (cf. Leo's mail 2013-11-16) *)
+module F (M : sig end) : sig type t end = struct type t = int end
+module T = struct
+  module M = struct end
+  include F(M)
+end;;
+include T;;
+let f (x : t) : T.t = x ;;
+
+(* PR#4049 *)
+(* This works thanks to abbreviations *)
+module A = struct
+  module B = struct type t let compare x y = 0 end
+  module S = Set.Make(B)
+  let empty = S.empty
+end
+module A1 = A;;
+A1.empty = A.empty;;
+
+(* PR#3476 *)
+(* Does not work yet *)
+module FF(X : sig end) = struct type t end
+module M = struct
+  module X = struct end
+  module Y = FF (X) (* XXX *)
+  type t = Y.t
+end
+module F (Y : sig type t end) (M : sig type t = Y.t end) = struct end;;
+
+module G = F (M.Y);;
+(*module N = G (M);;
+module N = F (M.Y) (M);;*)
+
+(* PR#6307 *)
+
+module A1 = struct end
+module A2 = struct end
+module L1 = struct module X = A1 end
+module L2 = struct module X = A2 end;;
+
+module F (L : (module type of L1)) = struct end;;
+
+module F1 = F(L1);; (* ok *)
+module F2 = F(L2);; (* should succeed too *)
+
+(* Counter example: why we need to be careful with PR#6307 *)
+module Int = struct type t = int let compare = compare end
+module SInt = Set.Make(Int)
+type (_,_) eq = Eq : ('a,'a) eq
+type wrap = W of (SInt.t, SInt.t) eq
+
+module M = struct
+  module I = Int
+  type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(I).t) eq
+end;;
+module type S = module type of M;; (* keep alias *)
+
+module Int2 = struct type t = int let compare x y = compare y x end;;
+module type S' = sig
+  module I = Int2
+  include S with module I := I
+end;; (* fail *)
+
+(* (* if the above succeeded, one could break invariants *)
+module rec M2 : S' = M2;; (* should succeed! (but this is bad) *)
+
+let M2.W eq = W Eq;;
+
+let s = List.fold_right SInt.add [1;2;3] SInt.empty;;
+module SInt2 = Set.Make(Int2);;
+let conv : type a b. (a,b) eq -> a -> b = fun Eq x -> x;;
+let s' : SInt2.t = conv eq s;;
+SInt2.elements s';;
+SInt2.mem 2 s';; (* invariants are broken *)
+*)
+
+(* Check behavior with submodules *)
+module M = struct
+  module N = struct module I = Int end
+  module P = struct module I = N.I end
+  module Q = struct
+    type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(P.I).t) eq
+  end
+end;;
+module type S = module type of M ;;
+
+module M = struct
+  module N = struct module I = Int end
+  module P = struct module I = N.I end
+  module Q = struct
+    type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(N.I).t) eq
+  end
+end;;
+module type S = module type of M ;;
+
+(* PR#6365 *)
+module type S = sig module M : sig type t val x : t end end;;
+module H = struct type t = A let x = A end;;
+module H' = H;;
+module type S' = S with module M = H';; (* shouldn't introduce an alias *)
+
+(* PR#6376 *)
+module type Alias = sig module N : sig end module M = N end;;
+module F (X : sig end) = struct type t end;;
+module type A = Alias with module N := F(List);;
+module rec Bad : A = Bad;;
+
+(* Shinwell 2014-04-23 *)
+module B = struct
+ module R = struct
+   type t = string
+ end
+
+ module O = R
+end
+
+module K = struct
+ module E = B
+ module N = E.O
+end;;
+
+let x : K.N.t = "foo";;
+
+(* PR#6465 *)
+
+module M = struct type t = A module B = struct type u = B end end;;
+module P : sig type t = M.t = A module B = M.B end = M;; (* should be ok *)
+module P : sig type t = M.t = A module B = M.B end = struct include M end;;
+
+module type S = sig
+  module M : sig module P : sig end end
+  module Q = M
+end;;
+module type S = sig
+  module M : sig module N : sig end module P : sig end end
+  module Q : sig module N = M.N module P = M.P end
+end;;
+module R = struct
+  module M = struct module N = struct end module P = struct end end
+  module Q = M
+end;;
+module R' : S = R;; (* should be ok *)
+
+(* PR#6578 *)
+
+module M = struct let f x = x end
+module rec R : sig module M : sig val f : 'a -> 'a end end =
+  struct module M = M end;;
+R.M.f 3;;
+module rec R : sig module M = M end = struct module M = M end;;
+R.M.f 3;;
+open A
+let f =
+  L.map S.capitalize
+
+let () =
+  L.iter print_endline (f ["jacques"; "garrigue"])
+
+module C : sig module L : module type of List end = struct include A end
+
+(* The following introduces a (useless) dependency on A:
+module C : sig module L : module type of List end = A
+*)
+
+include D'
+(*
+let () =
+  print_endline (string_of_int D'.M.y)
+*)
+open A
+let f =
+  L.map S.capitalize
+
+let () =
+  L.iter print_endline (f ["jacques"; "garrigue"])
+
+module C : sig module L : module type of List end = struct include A end
+
+(* The following introduces a (useless) dependency on A:
+module C : sig module L : module type of List end = A
+*)
+
+(* No dependency on D *)
+let x = 3
+module M = struct let y = 5 end
+module type S = sig type u type t end;;
+module type S' = sig type t = int type u = bool end;;
+
+(* ok to convert between structurally equal signatures, and parameters
+   are inferred *)
+let f (x : (module S with type t = 'a and type u = 'b)) = (x : (module S'));;
+let g x = (x : (module S with type t = 'a and type u = 'b) :> (module S'));;
+
+(* with subtyping it is also ok to forget some types *)
+module type S2 = sig type u type t type w end;;
+let g2 x = (x : (module S2 with type t = 'a and type u = 'b) :> (module S'));;
+let h x = (x : (module S2 with type t = 'a) :> (module S with type t = 'a));;
+let f2 (x : (module S2 with type t = 'a and type u = 'b)) =
+  (x : (module S'));; (* fail *)
+let k (x : (module S2 with type t = 'a)) =
+  (x : (module S with type t = 'a));; (* fail *)
+
+(* but you cannot forget values (no physical coercions) *)
+module type S3 = sig type u type t val x : int end;;
+let g3 x =
+  (x : (module S3 with type t = 'a and type u = 'b) :> (module S'));; (* fail *)
+(* Using generative functors *)
+
+(* Without type *)
+module type S = sig val x : int end;;
+let v = (module struct let x = 3 end : S);;
+module F() = (val v);; (* ok *)
+module G (X : sig end) : S = F ();; (* ok *)
+module H (X : sig end) = (val v);; (* ok *)
+
+(* With type *)
+module type S = sig type t val x : t end;;
+let v = (module struct type t = int let x = 3 end : S);;
+module F() = (val v);; (* ok *)
+module G (X : sig end) : S = F ();; (* fail *)
+module H() = F();; (* ok *)
+
+(* Alias *)
+module U = struct end;;
+module M = F(struct end);; (* ok *)
+module M = F(U);; (* fail *)
+
+(* Cannot coerce between applicative and generative *)
+module F1 (X : sig end) = struct end;;
+module F2 : functor () -> sig end = F1;; (* fail *)
+module F3 () = struct end;;
+module F4 : functor (X : sig end) -> sig end = F3;; (* fail *)
+
+(* tests for shortened functor notation () *)
+module X (X: sig end) (Y: sig end) = functor (Z: sig end) -> struct end;;
+module Y = functor (X: sig end) (Y:sig end) -> functor (Z: sig end) ->
+  struct end;;
+module Z = functor (_: sig end) (_:sig end) (_: sig end) -> struct end;;
+module GZ : functor (X: sig end) () (Z: sig end) -> sig end
+          = functor (X: sig end) () (Z: sig end) -> struct end;;
+module F (X : sig end) = struct type t = int end;;
+type t = F(Does_not_exist).t;;
+type expr =
+  [ `Abs of string * expr
+  | `App of expr * expr
+  ]
+
+class type exp =
+object
+  method eval : (string, exp) Hashtbl.t -> expr
+end;;
+
+class app e1 e2 : exp =
+object
+  val l = e1
+  val r = e2
+  method eval env =
+      match l with
+    | `Abs(var,body) ->
+        Hashtbl.add env var r;
+        body
+    | _ -> `App(l,r);
+end
+
+class virtual ['subject, 'event] observer =
+   object
+     method virtual notify : 'subject ->  'event -> unit
+   end
+
+class ['event] subject =
+   object (self : 'subject)
+     val mutable observers = ([]: (('subject, 'event) observer) list)
+     method add_observer obs = observers <- (obs :: observers)
+     method notify_observers (e : 'event) =
+         List.iter (fun x -> x#notify self e) observers
+   end
+
+type id = int
+
+class entity (id : id) =
+  object
+    val ent_destroy_subject = new subject
+    method destroy_subject : (id) subject = ent_destroy_subject
+
+    method entity_id = id
+  end
+
+class ['entity] entity_container =
+  object (self)
+    inherit ['entity, id] observer as observer
+
+    method add_entity (e : 'entity) =
+      e#destroy_subject#add_observer (self)
+
+    method notify _ id = ()
+  end
+
+let f (x : entity entity_container) = ()
+
+(*
+class world =
+  object
+    val entity_container : entity entity_container = new entity_container
+
+    method add_entity (s : entity) =
+      entity_container#add_entity (s :> entity)
+
+  end
+*)
+(* Two v's in the same class *)
+class c v = object initializer  print_endline v val v = 42 end;;
+new c "42";;
+
+(* Two hidden v's in the same class! *)
+class c (v : int) =
+  object
+    method v0 = v
+    inherit ((fun v -> object method v : string = v end) "42")
+  end;;
+(new c 42)#v0;;
+class virtual ['a] c =
+object (s : 'a)
+  method virtual m : 'b
+end
+
+let o =
+    object (s :'a)
+      inherit ['a] c
+      method m = 42
+    end
+module M :
+   sig
+     class x : int -> object method m : int end
+  end
+=
+struct
+  class x _ = object
+    method m = 42
+  end
+end;;
+module M : sig class c : 'a -> object val x : 'b end end =
+  struct class c x = object val x = x end end
+
+class c (x : int) = object inherit M.c x method x : bool = x end
+
+let r = (new c 2)#x;;
+(* test.ml *)
+class alfa = object(_:'self)
+  method x: 'a. ('a, out_channel, unit) format -> 'a = Printf.printf
+end
+
+class bravo a = object
+  val y = (a :> alfa)
+  initializer y#x "bravo initialized"
+end
+
+class charlie a = object
+  inherit bravo a
+  initializer y#x "charlie initialized"
+end
+(* The module begins *)
+exception Out_of_range
+
+class type ['a] cursor =
+  object
+    method get : 'a
+    method incr : unit -> unit
+    method is_last : bool
+  end
+
+class type ['a] storage =
+  object ('self)
+    method first : 'a cursor
+    method len : int
+    method nth : int -> 'a cursor
+    method copy : 'self
+    method sub : int -> int -> 'self
+    method concat : 'a storage -> 'self
+    method fold : 'b. ('a -> int -> 'b -> 'b) -> 'b -> 'b
+    method iter : ('a -> unit) -> unit
+  end
+
+class virtual ['a, 'cursor] storage_base =
+  object (self : 'self)
+    constraint 'cursor = 'a #cursor
+    method virtual first : 'cursor
+    method virtual len : int
+    method virtual copy : 'self
+    method virtual sub : int -> int -> 'self
+    method virtual concat : 'a storage -> 'self
+    method fold : 'b. ('a -> int -> 'b -> 'b) -> 'b -> 'b = fun f a0 ->
+      let cur = self#first in
+      let rec loop count a =
+        if count >= self#len then a else
+        let a' = f cur#get count a in
+        cur#incr (); loop (count + 1) a'
+      in
+      loop 0 a0
+    method iter proc =
+      let p = self#first in
+      for i = 0 to self#len - 2 do proc p#get; p#incr () done;
+      if self#len > 0 then proc p#get else ()
+  end
+
+class type ['a] obj_input_channel =
+  object
+    method get : unit -> 'a
+    method close : unit -> unit
+  end
+
+class type ['a] obj_output_channel =
+  object
+    method put : 'a -> unit
+    method flush : unit -> unit
+    method close : unit -> unit
+  end
+
+module UChar =
+struct
+
+  type t = int
+
+  let highest_bit = 1 lsl 30
+  let lower_bits = highest_bit - 1
+
+  let char_of c =
+    try Char.chr c with Invalid_argument _ ->  raise Out_of_range
+
+  let of_char = Char.code
+
+  let code c =
+    if c lsr 30 = 0
+    then c
+    else raise Out_of_range
+
+  let chr n =
+    if n >= 0 && (n lsr 31 = 0) then n else raise Out_of_range
+
+  let uint_code c = c
+  let chr_of_uint n = n
+
+end
+
+type uchar = UChar.t
+
+let int_of_uchar u = UChar.uint_code u
+let uchar_of_int n = UChar.chr_of_uint n
+
+class type ucursor = [uchar] cursor
+
+class type ustorage = [uchar] storage
+
+class virtual ['ucursor] ustorage_base = [uchar, 'ucursor] storage_base
+
+module UText =
+struct
+
+(* the internal representation is UCS4 with big endian*)
+(* The most significant digit appears first. *)
+let get_buf s i =
+  let n = Char.code s.[i] in
+  let n = (n lsl 8) lor (Char.code s.[i + 1]) in
+  let n = (n lsl 8) lor (Char.code s.[i + 2]) in
+  let n = (n lsl 8) lor (Char.code s.[i + 3]) in
+  UChar.chr_of_uint n
+
+let set_buf s i u =
+  let n = UChar.uint_code u in
+  begin
+    s.[i] <- Char.chr (n lsr 24);
+    s.[i + 1] <- Char.chr (n lsr 16 lor 0xff);
+    s.[i + 2] <- Char.chr (n lsr 8 lor 0xff);
+    s.[i + 3] <- Char.chr (n lor 0xff);
+  end
+
+let init_buf buf pos init =
+  if init#len = 0 then () else
+  let cur = init#first in
+  for i = 0 to init#len - 2 do
+    set_buf buf (pos + i lsl 2) (cur#get); cur#incr ()
+  done;
+  set_buf buf (pos + (init#len - 1) lsl 2) (cur#get)
+
+let make_buf init =
+  let s = String.create (init#len lsl 2) in
+  init_buf s 0 init; s
+
+class text_raw buf =
+  object (self : 'self)
+    inherit [cursor] ustorage_base
+    val contents = buf
+    method first = new cursor (self :> text_raw) 0
+    method len = (String.length contents) / 4
+    method get i = get_buf contents (4 * i)
+    method nth i = new cursor (self :> text_raw) i
+    method copy = {< contents = String.copy contents >}
+    method sub pos len =
+      {< contents = String.sub contents (pos * 4) (len * 4) >}
+    method concat (text : ustorage) =
+      let buf = String.create (String.length contents + 4 * text#len) in
+      String.blit contents 0 buf 0 (String.length contents);
+      init_buf buf (String.length contents) text;
+      {< contents = buf >}
+  end
+and cursor text i =
+  object
+    val contents = text
+    val mutable pos = i
+    method get = contents#get pos
+    method incr () = pos <- pos + 1
+    method is_last = (pos + 1 >= contents#len)
+  end
+
+class string_raw buf =
+  object
+    inherit text_raw buf
+    method set i u = set_buf contents (4 * i) u
+  end
+
+class text init = text_raw (make_buf init)
+class string init = string_raw (make_buf init)
+
+let of_string s =
+  let buf = String.make (4 * String.length s) '\000' in
+  for i = 0 to String.length s - 1 do
+    buf.[4 * i] <- s.[i]
+  done;
+  new text_raw buf
+
+let make len u =
+  let s = String.create (4 * len) in
+  for i = 0 to len - 1 do set_buf s (4 * i) u done;
+  new string_raw s
+
+let create len = make len (UChar.chr 0)
+
+let copy s = s#copy
+
+let sub s start len = s#sub start len
+
+let fill s start len u =
+  for i = start to start + len - 1 do s#set i u done
+
+let blit src srcoff dst dstoff len =
+  for i = 0 to len - 1 do
+    let u = src#get (srcoff + i) in
+    dst#set (dstoff + i) u
+  done
+
+let concat s1 s2 = s1#concat (s2 (* : #ustorage *) :> uchar storage)
+
+let iter proc s = s#iter proc
+end
+class type foo_t =
+  object
+    method foo: string
+  end
+
+type 'a name =
+    Foo: foo_t name
+  | Int: int name
+;;
+
+class foo =
+  object(self)
+    method foo = "foo"
+    method cast =
+      function
+          Foo -> (self :> )
+  end
+;;
+
+class foo: foo_t =
+  object(self)
+    method foo = "foo"
+    method cast: type a. a name -> a =
+      function
+          Foo -> (self :> foo_t)
+        | _ -> raise Exit
+  end
+;;
+class type c = object end;;
+module type S = sig class c: c end;;
+class virtual name =
+object
+end
+
+and func (args_ty, ret_ty) =
+object(self)
+  inherit name
+
+  val mutable memo_args = None
+
+  method arguments =
+    match memo_args with
+    | Some xs -> xs
+    | None ->
+      let args = List.map (fun ty -> new argument(self, ty)) args_ty in
+        memo_args <- Some args; args
+end
+
+and argument (func, ty) =
+object
+  inherit name
+end
+;;
+let f (x: #M.foo) = 0;;
+class type ['e] t = object('s)
+  method update : 'e -> 's
+end;;
+
+module type S = sig
+  class base : 'e -> ['e] t
+end;;
+type 'par t = 'par
+module M : sig val x :  end =
+  struct let x :  = Obj.magic () end
+
+let ident v = v
+class alias = object method alias : 'a . 'a t -> 'a = ident end
+module Classdef = struct
+  class virtual ['a, 'b, 'c] cl0 =
+    object
+      constraint 'c = < m : 'a -> 'b -> int; .. >
+    end
+
+  class virtual ['a, 'b] cl1 =
+    object
+      method virtual raise_trouble : int -> 'a
+      method virtual m : 'a -> 'b -> int
+    end
+
+  class virtual ['a, 'b] cl2 =
+    object
+      method virtual as_cl0 : ('a, 'b, ('a, 'b) cl1) cl0
+    end
+end
+
+type refer1 = < poly : 'a 'b 'c . (('b, 'c) #Classdef.cl2 as 'a) >
+type refer2 = < poly : 'a 'b 'c . (('b, 'c) #Classdef.cl2 as 'a) >
+
+(* Actually this should succeed ... *)
+let f (x : refer1) = (x : refer2)
+module Classdef = struct
+  class virtual ['a, 'b, 'c] cl0 =
+    object
+      constraint 'c = < m : 'a -> 'b -> int; .. >
+    end
+
+  class virtual ['a, 'b] cl1 =
+    object
+      method virtual raise_trouble : int -> 'a
+      method virtual m : 'a -> 'b -> int
+    end
+
+  class virtual ['a, 'b] cl2 =
+    object
+      method virtual as_cl0 : ('a, 'b, ('a, 'b) cl1) cl0
+    end
+end
+
+module M : sig
+  type refer = { poly : 'a 'b 'c . (('b, 'c) #Classdef.cl2 as 'a) }
+end = struct
+  type refer = { poly : 'a 'b 'c . (('b, 'c) #Classdef.cl2 as 'a) }
+end
+(*
+  ocamlc -c pr3918a.mli pr3918b.mli
+  rm -f pr3918a.cmi
+  ocamlc -c pr3918c.ml
+*)
+
+open Pr3918b
+
+let f x = (x : 'a vlist :> 'b vlist)
+let f (x : 'a vlist) = (x : 'b vlist)
+module type Poly = sig
+  type 'a t = 'a constraint 'a = [> ]
+end
+
+module Combine (A : Poly) (B : Poly) = struct
+  type ('a, 'b) t = 'a A.t constraint 'a = 'b B.t
+end
+
+module C = Combine
+  (struct type 'a t = 'a constraint 'a = [> ] end)
+  (struct type 'a t = 'a constraint 'a = [> ] end)
+module type Priv = sig
+  type t = private int
+end
+
+module Make (Unit:sig end): Priv = struct type t = int end
+
+module A = Make (struct end)
+
+module type Priv' = sig
+  type t = private [> `A]
+end
+
+module Make' (Unit:sig end): Priv' = struct type t = [`A] end
+
+module A' = Make' (struct end)
+(* PR5057 *)
+
+module TT = struct
+  module IntSet = Set.Make(struct type t = int let compare = compare end)
+end
+
+let () =
+  let f flag =
+    let module T = TT in
+    let _ = match flag with `A -> 0 | `B r -> r in
+    let _ = match flag with `A -> T.IntSet.mem | `B r -> r in
+    ()
+  in
+  f `A
+(* This one should fail *)
+
+let f flag =
+  let module T = Set.Make(struct type t = int let compare = compare end) in
+  let _ = match flag with `A -> 0 | `B r -> r in
+  let _ = match flag with `A -> T.mem | `B r -> r in
+  ()
+module type S = sig
+ type +'a t
+
+ val foo : [`A] t -> unit
+ val bar : [< `A | `B] t -> unit
+end
+
+module Make(T : S) = struct
+ let f x =
+   T.foo x;
+   T.bar x;
+   (x :> [`A | `C] T.t)
+end
+type 'a termpc =
+    [`And of 'a * 'a
+    |`Or of 'a * 'a
+    |`Not of 'a
+    |`Atom of string
+    ]
+
+type 'a termk =
+    [`Dia of 'a
+    |`Box of 'a
+    |'a termpc
+    ]
+
+module type T = sig
+  type term
+  val map : (term -> term) -> term -> term
+  val nnf : term -> term
+  val nnf_not : term -> term
+end
+
+module Fpc(X : T with type term = private [> 'a termpc] as 'a) =
+  struct
+    type term = X.term termpc
+    let nnf = function
+      |`Not(`Atom _) as x -> x
+      |`Not x     -> X.nnf_not x
+      | x         -> X.map X.nnf x
+    let map f : term -> X.term = function
+      |`Not x    -> `Not (f x)
+      |`And(x,y) -> `And (f x, f y)
+      |`Or (x,y) -> `Or  (f x, f y)
+      |`Atom _ as x -> x
+    let nnf_not : term -> _ = function
+      |`Not x    -> X.nnf x
+      |`And(x,y) -> `Or  (X.nnf_not x, X.nnf_not y)
+      |`Or (x,y) -> `And (X.nnf_not x, X.nnf_not y)
+      |`Atom _ as x -> `Not x
+  end
+
+module Fk(X : T with type term = private [> 'a termk] as 'a) =
+  struct
+    type term = X.term termk
+    module Pc = Fpc(X)
+    let map f : term -> _ = function
+      |`Dia x -> `Dia (f x)
+      |`Box x -> `Box (f x)
+      |#termpc as x -> Pc.map f x
+    let nnf = Pc.nnf
+    let nnf_not : term -> _ = function
+      |`Dia x -> `Box (X.nnf_not x)
+      |`Box x -> `Dia (X.nnf_not x)
+      |#termpc as x -> Pc.nnf_not x
+  end
+type untyped;;
+type -'a typed = private untyped;;
+type -'typing wrapped = private sexp
+and +'a t = 'a typed wrapped
+and sexp = private untyped wrapped;;
+class type ['a] s3 = object
+  val underlying : 'a t
+end;;
+class ['a] s3object r : ['a] s3 = object
+  val underlying = r
+end;;
+module M (T:sig type t end)
+ = struct type t = private { t : T.t } end
+module P
+ = struct
+       module T = struct type t end
+       module R = M(T)
+ end
+module Foobar : sig
+  type t = private int
+end = struct
+  type t = int
+end;;
+
+module F0 : sig type t = private int end = Foobar;;
+
+let f (x : F0.t) = (x : Foobar.t);; (* fails *)
+
+module F = Foobar;;
+
+let f (x : F.t) = (x : Foobar.t);;
+
+module M = struct type t =  end;;
+module M1 : sig type t = private  end = M;;
+module M2 :  sig type t = private  end = M1;;
+fun (x : M1.t) -> (x : M2.t);; (* fails *)
+
+module M3 : sig type t = private M1.t end = M1;;
+fun x -> (x : M3.t :> M1.t);;
+fun x -> (x : M3.t :> M.t);;
+module M4 : sig type t = private M3.t end = M2;; (* fails *)
+module M4 : sig type t = private M3.t end = M;; (* fails *)
+module M4 : sig type t = private M3.t end = M1;; (* might be ok *)
+module M5 : sig type t = private M1.t end = M3;;
+module M6 : sig type t = private < n:int; .. > end = M1;; (* fails *)
+
+module Bar : sig type t = private Foobar.t val f : int -> t end =
+  struct type t = int let f (x : int) = (x : t) end;; (* must fail *)
+
+module M : sig
+  type t = private T of int
+  val mk : int -> t
+end = struct
+  type t = T of int
+  let mk x = T(x)
+end;;
+
+module M1 : sig
+  type t = M.t
+  val mk : int -> t
+end = struct
+  type t = M.t
+  let mk = M.mk
+end;;
+
+module M2 : sig
+  type t = M.t
+  val mk : int -> t
+end = struct
+  include M
+end;;
+
+module M3 : sig
+  type t = M.t
+  val mk : int -> t
+end = M;;
+
+module M4 : sig
+    type t = M.t = T of int
+    val mk : int -> t
+  end = M;;
+(* Error: The variant or record definition does not match that of type M.t *)
+
+module M5 : sig
+  type t = M.t = private T of int
+  val mk : int -> t
+end = M;;
+
+module M6 : sig
+  type t = private T of int
+  val mk : int -> t
+end = M;;
+
+module M' : sig
+  type t_priv = private T of int
+  type t = t_priv
+  val mk : int -> t
+end = struct
+  type t_priv = T of int
+  type t = t_priv
+  let mk x = T(x)
+end;;
+
+module M3' : sig
+  type t = M'.t
+  val mk : int -> t
+end = M';;
+
+module M : sig type 'a t = private T of 'a end =
+  struct type 'a t = T of 'a end;;
+
+module M1 : sig type 'a t = 'a M.t = private T of 'a end =
+  struct type 'a t = 'a M.t = private T of 'a end;;
+
+(* PR#6090 *)
+module Test = struct type t = private A end
+module Test2 : module type of Test with type t = Test.t = Test;;
+let f (x : Test.t) = (x : Test2.t);;
+let f Test2.A = ();;
+let a = Test2.A;; (* fail *)
+(* The following should fail from a semantical point of view,
+   but allow it for backward compatibility *)
+module Test2 : module type of Test with type t = private Test.t = Test;;
+
+(* PR#6331 *)
+type t = private < x : int; .. > as 'a;;
+type t = private (< x : int; .. > as 'a) as 'a;;
+type t = private < x : int > as 'a;;
+type t = private (< x : int > as 'a) as 'b;;
+type 'a t = private < x : int; .. > as 'a;;
+type 'a t = private 'a constraint 'a = < x : int; .. >;;
+(* Bad (t = t) *)
+module rec A : sig type t = A.t end = struct type t = A.t end;;
+(* Bad (t = t) *)
+module rec A : sig type t = B.t end = struct type t = B.t end
+       and B : sig type t = A.t end = struct type t = A.t end;;
+(* OK (t = int) *)
+module rec A : sig type t = B.t end = struct type t = B.t end
+       and B : sig type t = int end = struct type t = int end;;
+(* Bad (t = int * t) *)
+module rec A : sig type t = int * A.t end = struct type t = int * A.t end;;
+(* Bad (t = t -> int) *)
+module rec A : sig type t = B.t -> int end = struct type t = B.t -> int end
+       and B : sig type t = A.t end = struct type t = A.t end;;
+(* OK (t = ) *)
+module rec A : sig type t =  end = struct type t =  end
+       and B : sig type t = A.t end = struct type t = A.t end;;
+(* Bad (not regular) *)
+module rec A : sig type 'a t =  end
+             = struct type 'a t =  end;;
+(* Bad (not regular) *)
+module rec A : sig type 'a t =  end
+             = struct type 'a t =  end
+       and B : sig type 'a t = 'a A.t end = struct type 'a t = 'a A.t end;;
+(* Bad (not regular) *)
+module rec A : sig type 'a t = 'a B.t end
+             = struct type 'a t = 'a B.t end
+       and B : sig type 'a t =  end
+             = struct type 'a t =  end;;
+(* OK *)
+module rec A : sig type 'a t = 'a array B.t * 'a list B.t end
+             = struct type 'a t = 'a array B.t * 'a list B.t end
+       and B : sig type 'a t =  end
+             = struct type 'a t =  end;;
+(* Bad (not regular) *)
+module rec A : sig type 'a t = 'a list B.t end
+             = struct type 'a t = 'a list B.t end
+       and B : sig type 'a t =  end
+             = struct type 'a t =  end;;
+(* Bad (not regular) *)
+module rec M :
+    sig
+      class ['a] c : 'a -> object
+        method map : ('a -> 'b) -> 'b M.c
+      end
+    end
+  = struct
+      class ['a] c (x : 'a) = object
+        method map : 'b. ('a -> 'b) -> 'b M.c
+          = fun f -> new M.c (f x)
+      end
+    end;;
+(* OK *)
+class type [ 'node ] extension = object method node : 'node end
+and [ 'ext ] node = object constraint 'ext = 'ext node #extension [@id] end
+class x = object method node : x node = assert false end
+type t = x node;;
+(* Bad - PR 4261 *)
+
+module PR_4261 = struct
+  module type S =
+  sig
+    type t
+  end
+
+  module type T =
+  sig
+    module D : S
+    type t = D.t
+  end
+
+  module rec U : T with module D = U' = U
+  and U' : S with type t = U'.t = U
+end;;
+(* Bad - PR 4512 *)
+module type S' = sig type t = int end
+module rec M : S' with type t = M.t = struct type t = M.t end;;
+(* PR#4450 *)
+
+module PR_4450_1 = struct
+  module type MyT = sig type 'a t = Succ of 'a t end
+  module MyMap(X : MyT) = X
+  module rec MyList : MyT = MyMap(MyList)
+end;;
+
+module PR_4450_2 = struct
+  module type MyT = sig
+    type 'a wrap = My of 'a t
+    and 'a t = private < map : 'b. ('a -> 'b) ->'b wrap; .. >
+    val create : 'a list -> 'a t
+  end
+  module MyMap(X : MyT) = struct
+    include X
+    class ['a] c l = object (self)
+      method map : 'b. ('a -> 'b) -> 'b wrap =
+        fun f -> My (create (List.map f l))
+    end
+  end
+  module rec MyList : sig
+    type 'a wrap = My of 'a t
+    and 'a t = < map : 'b. ('a -> 'b) ->'b wrap >
+    val create : 'a list -> 'a t
+  end = struct
+    include MyMap(MyList)
+    let create l = new c l
+  end
+end;;
+(* A synthetic example of bootstrapped data structure
+   (suggested by J-C Filliatre) *)
+
+module type ORD = sig
+  type t
+  val compare : t -> t -> int
+end
+
+module type SET = sig
+  type elt
+  type t
+  val iter : (elt -> unit) -> t -> unit
+end
+
+type 'a tree = E | N of 'a tree * 'a * 'a tree
+
+module Bootstrap2
+  (MakeDiet : functor (X: ORD) -> SET with type t = X.t tree and type elt = X.t)
+  : SET with type elt = int =
+struct
+
+  type elt = int
+
+  module rec Elt : sig
+    type t = I of int * int | D of int * Diet.t * int
+    val compare : t -> t -> int
+    val iter : (int -> unit) -> t -> unit
+  end =
+  struct
+    type t = I of int * int | D of int * Diet.t * int
+    let compare x1 x2 = 0
+    let rec iter f = function
+      | I (l, r) -> for i = l to r do f i done
+      | D (_, d, _) -> Diet.iter (iter f) d
+  end
+
+  and Diet : SET with type t = Elt.t tree and type elt = Elt.t = MakeDiet(Elt)
+
+  type t = Diet.t
+  let iter f = Diet.iter (Elt.iter f)
+end
+(* PR 4470: simplified from OMake's sources *)
+
+module rec DirElt
+  : sig
+      type t = DirRoot | DirSub of DirHash.t
+    end
+  = struct
+      type t = DirRoot | DirSub of DirHash.t
+    end
+
+and DirCompare
+  : sig
+      type t = DirElt.t
+    end
+  = struct
+      type t = DirElt.t
+    end
+
+and DirHash
+  : sig
+      type t = DirElt.t list
+    end
+  = struct
+      type t = DirCompare.t list
+    end
+(* PR 4758, PR 4266 *)
+
+module PR_4758 = struct
+  module type S = sig end
+  module type Mod = sig
+    module Other : S
+  end
+  module rec A : S = struct end
+  and C : sig include Mod with module Other = A end = struct
+    module Other = A
+  end
+  module C' = C  (* check that we can take an alias *)
+  module F(X:sig end) = struct type t end
+  let f (x : F(C).t) = (x : F(C').t)
+end
+(* PR 4557 *)
+module PR_4557 = struct
+  module F ( X : Set.OrderedType ) = struct
+    module rec Mod : sig
+      module XSet :
+        sig
+          type elt = X.t
+          type t = Set.Make( X ).t
+        end
+      module XMap :
+        sig
+          type key = X.t
+          type 'a t = 'a Map.Make(X).t
+        end
+      type elt = X.t
+      type t = XSet.t XMap.t
+      val compare: t -> t -> int
+    end
+       =
+    struct
+      module XSet = Set.Make( X )
+      module XMap = Map.Make( X )
+
+      type elt = X.t
+      type t = XSet.t XMap.t
+      let compare = (fun x y -> 0)
+    end
+    and ModSet : Set.S with type elt = Mod.t = Set.Make( Mod )
+  end
+end
+module F ( X : Set.OrderedType ) = struct
+  module rec Mod : sig
+    module XSet :
+      sig
+        type elt = X.t
+        type t = Set.Make( X ).t
+      end
+    module XMap :
+      sig
+        type key = X.t
+        type 'a t = 'a Map.Make(X).t
+      end
+    type elt = X.t
+    type t = XSet.t XMap.t
+    val compare: t -> t -> int
+  end
+     =
+  struct
+    module XSet = Set.Make( X )
+    module XMap = Map.Make( X )
+
+    type elt = X.t
+    type t = XSet.t XMap.t
+    let compare = (fun x y -> 0)
+  end
+  and ModSet : Set.S with type elt = Mod.t = Set.Make( Mod )
+end
+(* Tests for recursive modules *)
+
+let test number result expected =
+  if result = expected
+  then Printf.printf "Test %d passed.\n" number
+  else Printf.printf "Test %d FAILED.\n" number;
+  flush stdout
+
+(* Tree of sets *)
+
+module rec A
+ : sig
+     type t = Leaf of int | Node of ASet.t
+     val compare: t -> t -> int
+   end
+ = struct
+     type t = Leaf of int | Node of ASet.t
+     let compare x y =
+       match (x,y) with
+         (Leaf i, Leaf j) -> Pervasives.compare i j
+       | (Leaf i, Node t) -> -1
+       | (Node s, Leaf j) -> 1
+       | (Node s, Node t) -> ASet.compare s t
+   end
+
+and ASet : Set.S with type elt = A.t = Set.Make(A)
+;;
+
+let _ =
+  let x = A.Node (ASet.add (A.Leaf 3) (ASet.singleton (A.Leaf 2))) in
+  let y = A.Node (ASet.add (A.Leaf 1) (ASet.singleton x)) in
+  test 10 (A.compare x x) 0;
+  test 11 (A.compare x (A.Leaf 3)) 1;
+  test 12 (A.compare (A.Leaf 0) x) (-1);
+  test 13 (A.compare y y) 0;
+  test 14 (A.compare x y) 1
+;;
+
+(* Simple value recursion *)
+
+module rec Fib
+  : sig val f : int -> int end
+  = struct let f x = if x < 2 then 1 else Fib.f(x-1) + Fib.f(x-2) end
+;;
+
+let _ =
+  test 20 (Fib.f 10) 89
+;;
+
+(* Update function by infix *)
+
+module rec Fib2
+  : sig val f : int -> int end
+  = struct let rec g x = Fib2.f(x-1) + Fib2.f(x-2)
+               and f x = if x < 2 then 1 else g x
+    end
+;;
+
+let _ =
+  test 21 (Fib2.f 10) 89
+;;
+
+(* Early application *)
+
+let _ =
+  let res =
+    try
+      let module A =
+        struct
+          module rec Bad
+            : sig val f : int -> int end
+            = struct let f = let y = Bad.f 5 in fun x -> x+y end
+          end in
+      false
+    with Undefined_recursive_module _ ->
+      true in
+  test 30 res true
+;;
+
+(* Early strict evaluation *)
+
+(*
+module rec Cyclic
+  : sig val x : int end
+  = struct let x = Cyclic.x + 1 end
+;;
+*)
+
+(* Reordering of evaluation based on dependencies *)
+
+module rec After
+  : sig val x : int end
+  = struct let x = Before.x + 1 end
+and Before
+  : sig val x : int end
+  = struct let x = 3 end
+;;
+
+let _ =
+  test 40 After.x 4
+;;
+
+(* Type identity between A.t and t within A's definition *)
+
+module rec Strengthen
+  : sig type t val f : t -> t end
+  = struct
+      type t = A | B
+      let _ = (A : Strengthen.t)
+      let f x = if true then A else Strengthen.f B
+    end
+;;
+
+module rec Strengthen2
+  : sig type t
+        val f : t -> t
+        module M : sig type u end
+        module R : sig type v end
+    end
+  = struct
+      type t = A | B
+      let _ = (A : Strengthen2.t)
+      let f x = if true then A else Strengthen2.f B
+      module M =
+        struct
+          type u = C
+          let _ = (C: Strengthen2.M.u)
+        end
+      module rec R : sig type v  = Strengthen2.R.v end =
+        struct
+          type v = D
+          let _ = (D : R.v)
+          let _ = (D : Strengthen2.R.v)
+        end
+    end
+;;
+
+(* Polymorphic recursion *)
+
+module rec PolyRec
+  : sig
+      type 'a t = Leaf of 'a | Node of 'a list t * 'a list t
+      val depth: 'a t -> int
+    end
+  = struct
+      type 'a t = Leaf of 'a | Node of 'a list t * 'a list t
+      let x = (PolyRec.Leaf 1 : int t)
+      let depth = function
+        Leaf x -> 0
+      | Node(l,r) -> 1 + max (PolyRec.depth l) (PolyRec.depth r)
+    end
+;;
+
+(* Wrong LHS signatures (PR#4336) *)
+
+(*
+module type ASig = sig type a val a:a val print:a -> unit end
+module type BSig = sig type b val b:b val print:b -> unit end
+
+module A = struct type a = int let a = 0 let print = print_int end
+module B = struct type b = float let b = 0.0 let print = print_float end
+
+module MakeA (Empty:sig end) : ASig = A
+module MakeB (Empty:sig end) : BSig = B
+
+module
+   rec NewA : ASig = MakeA (struct end)
+   and NewB : BSig with type b = NewA.a = MakeB (struct end);;
+
+*)
+
+(* Expressions and bindings *)
+
+module StringSet = Set.Make(String);;
+
+module rec Expr
+  : sig
+      type t =
+        Var of string
+      | Const of int
+      | Add of t * t
+      | Binding of Binding.t * t
+      val make_let: string -> t -> t -> t
+      val fv: t -> StringSet.t
+      val simpl: t -> t
+    end
+  = struct
+      type t =
+        Var of string
+      | Const of int
+      | Add of t * t
+      | Binding of Binding.t * t
+      let make_let id e1 e2 = Binding([id, e1], e2)
+      let rec fv = function
+        Var s -> StringSet.singleton s
+      | Const n -> StringSet.empty
+      | Add(t1,t2) -> StringSet.union (fv t1) (fv t2)
+      | Binding(b,t) ->
+          StringSet.union (Binding.fv b)
+            (StringSet.diff (fv t) (Binding.bv b))
+      let rec simpl = function
+        Var s -> Var s
+      | Const n -> Const n
+      | Add(Const i, Const j) -> Const (i+j)
+      | Add(Const 0, t) -> simpl t
+      | Add(t, Const 0) -> simpl t
+      | Add(t1,t2) -> Add(simpl t1, simpl t2)
+      | Binding(b, t) -> Binding(Binding.simpl b, simpl t)
+    end
+
+and Binding
+  : sig
+      type t = (string * Expr.t) list
+      val fv: t -> StringSet.t
+      val bv: t -> StringSet.t
+      val simpl: t -> t
+    end
+  = struct
+      type t = (string * Expr.t) list
+      let fv b =
+        List.fold_left (fun v (id,e) -> StringSet.union v (Expr.fv e))
+                       StringSet.empty b
+      let bv b =
+        List.fold_left (fun v (id,e) -> StringSet.add id v)
+                       StringSet.empty b
+      let simpl b =
+        List.map (fun (id,e) -> (id, Expr.simpl e)) b
+    end
+;;
+
+let _ =
+  let e = Expr.make_let "x" (Expr.Add (Expr.Var "y", Expr.Const 0))
+                            (Expr.Var "x") in
+  let e' = Expr.make_let "x" (Expr.Var "y") (Expr.Var "x") in
+  test 50 (StringSet.elements (Expr.fv e)) ["y"];
+  test 51 (Expr.simpl e) e'
+;;
+
+(* Okasaki's bootstrapping *)
+
+module type ORDERED =
+  sig
+    type t
+    val eq: t -> t -> bool
+    val lt: t -> t -> bool
+    val leq: t -> t -> bool
+  end
+
+module type HEAP =
+  sig
+    module Elem: ORDERED
+    type heap
+    val empty: heap
+    val isEmpty: heap -> bool
+    val insert: Elem.t -> heap -> heap
+    val merge: heap -> heap -> heap
+    val findMin: heap -> Elem.t
+    val deleteMin: heap -> heap
+  end
+
+module Bootstrap (MakeH: functor (Element:ORDERED) ->
+                                    HEAP with module Elem = Element)
+                 (Element: ORDERED) : HEAP with module Elem = Element =
+  struct
+    module Elem = Element
+    module rec BE
+    : sig type t = E | H of Elem.t * PrimH.heap
+          val eq: t -> t -> bool
+          val lt: t -> t -> bool
+          val leq: t -> t -> bool
+      end
+    = struct
+        type t = E | H of Elem.t * PrimH.heap
+        let leq t1 t2 =
+          match t1, t2 with
+          | (H(x, _)), (H(y, _)) -> Elem.leq x y
+          | H _, E -> false
+          | E, H _ -> true
+          | E, E -> true
+        let eq t1 t2 =
+          match t1, t2 with
+          | (H(x, _)), (H(y, _)) -> Elem.eq x y
+          | H _, E -> false
+          | E, H _ -> false
+          | E, E -> true
+        let lt t1 t2 =
+          match t1, t2 with
+          | (H(x, _)), (H(y, _)) -> Elem.lt x y
+          | H _, E -> false
+          | E, H _ -> true
+          | E, E -> false
+      end
+    and PrimH
+    : HEAP with type Elem.t = BE.t
+    = MakeH(BE)
+    type heap = BE.t
+    let empty = BE.E
+    let isEmpty = function BE.E -> true | _ -> false
+    let rec merge x y =
+      match (x,y) with
+        (BE.E, _) -> y
+      | (_, BE.E) -> x
+      | (BE.H(e1,p1) as h1), (BE.H(e2,p2) as h2) ->
+          if Elem.leq e1 e2
+          then BE.H(e1, PrimH.insert h2 p1)
+          else BE.H(e2, PrimH.insert h1 p2)
+    let insert x h =
+      merge (BE.H(x, PrimH.empty)) h
+    let findMin = function
+        BE.E -> raise Not_found
+      | BE.H(x, _) -> x
+    let deleteMin = function
+        BE.E -> raise Not_found
+      | BE.H(x, p) ->
+          if PrimH.isEmpty p then BE.E else begin
+            match PrimH.findMin p with
+            | (BE.H(y, p1)) ->
+              let p2 = PrimH.deleteMin p in
+              BE.H(y, PrimH.merge p1 p2)
+            | BE.E -> assert false
+          end
+  end
+;;
+
+module LeftistHeap(Element: ORDERED): HEAP with module Elem = Element =
+  struct
+    module Elem = Element
+    type heap = E | T of int * Elem.t * heap * heap
+    let rank = function E -> 0 | T(r,_,_,_) -> r
+    let make x a b =
+      if rank a >= rank b
+      then T(rank b + 1, x, a, b)
+      else T(rank a + 1, x, b, a)
+    let empty = E
+    let isEmpty = function E -> true | _ -> false
+    let rec merge h1 h2 =
+      match (h1, h2) with
+        (_, E) -> h1
+      | (E, _) -> h2
+      | (T(_, x1, a1, b1), T(_, x2, a2, b2)) ->
+          if Elem.leq x1 x2
+          then make x1 a1 (merge b1 h2)
+          else make x2 a2 (merge h1 b2)
+    let insert x h = merge (T(1, x, E, E)) h
+    let findMin = function
+      E -> raise Not_found
+    | T(_, x, _, _) -> x
+    let deleteMin = function
+      E -> raise Not_found
+    | T(_, x, a, b) -> merge a b
+  end
+;;
+
+module Ints =
+  struct
+    type t = int
+    let eq = (=)
+    let lt = (<)
+    let leq = (<=)
+  end
+;;
+
+module C = Bootstrap(LeftistHeap)(Ints);;
+
+let _ =
+  let h = List.fold_right C.insert [6;4;8;7;3;1] C.empty in
+  test 60 (C.findMin h) 1;
+  test 61 (C.findMin (C.deleteMin h)) 3;
+  test 62 (C.findMin (C.deleteMin (C.deleteMin h))) 4
+;;
+
+(* Classes *)
+
+module rec Class1
+  : sig
+      class c : object method m : int -> int end
+    end
+  = struct
+      class c =
+        object
+          method m x = if x <= 0 then x else (new Class2.d)#m x
+        end
+    end
+and Class2
+  : sig
+      class d : object method m : int -> int end
+    end
+  = struct
+      class d =
+        object(self)
+          inherit Class1.c as super
+          method m (x:int) = super#m 0
+        end
+    end
+;;
+
+let _ =
+  test 70 ((new Class1.c)#m 7) 0
+;;
+
+let _ =
+  try
+    let module A = struct
+       module rec BadClass1
+         : sig
+             class c : object method m : int end
+           end
+         = struct
+             class c = object method m = 123 end
+           end
+       and BadClass2
+         : sig
+             val x: int
+           end
+         = struct
+             let x = (new BadClass1.c)#m
+           end
+    end in
+      test 71 true false
+  with Undefined_recursive_module _ ->
+    test 71 true true
+;;
+
+(* Coercions *)
+
+module rec Coerce1
+  : sig
+      val g: int -> int
+      val f: int -> int
+    end
+  = struct
+      module A = (Coerce1: sig val f: int -> int end)
+      let g x = x
+      let f x = if x <= 0 then 1 else A.f (x-1) * x
+    end
+;;
+
+let _ =
+  test 80 (Coerce1.f 10) 3628800
+;;
+
+module CoerceF(S: sig end) = struct
+  let f1 () = 1
+  let f2 () = 2
+  let f3 () = 3
+  let f4 () = 4
+  let f5 () = 5
+end
+
+module rec Coerce2: sig val f1: unit -> int end = CoerceF(Coerce3)
+       and Coerce3: sig end = struct end
+;;
+
+let _ =
+  test 81 (Coerce2.f1 ()) 1
+;;
+
+module Coerce4(A : sig val f : int -> int end) = struct
+  let x = 0
+  let at a = A.f a
+end
+
+module rec Coerce5
+  : sig val blabla: int -> int val f: int -> int end
+  = struct let blabla x = 0 let f x = 5 end
+and Coerce6
+  : sig val at: int -> int end
+  = Coerce4(Coerce5)
+
+let _ =
+  test 82 (Coerce6.at 100) 5
+;;
+
+(* Miscellaneous bug reports *)
+
+module rec F
+  : sig type t = X of int | Y of int
+        val f: t -> bool
+    end
+  = struct
+      type t = X of int | Y of int
+      let f = function
+        | X _ -> false
+        | _ -> true
+    end;;
+
+let _ =
+  test 100 (F.f (F.X 1)) false;
+  test 101 (F.f (F.Y 2)) true
+
+(* PR#4316 *)
+module G(S : sig val x : int Lazy.t end) = struct include S end
+
+module M1 = struct let x = lazy 3 end
+
+let _ = Lazy.force M1.x
+
+module rec M2 : sig val x : int Lazy.t end = G(M1)
+
+let _ =
+  test 102 (Lazy.force M2.x) 3
+
+let _ = Gc.full_major()   (* will shortcut forwarding in M1.x *)
+
+module rec M3 : sig val x : int Lazy.t end = G(M1)
+
+let _ =
+  test 103 (Lazy.force M3.x) 3
+
+
+(** Pure type-checking tests: see recmod/*.ml  *)
+type t = A of {x:int; mutable y:int};;
+let f (A r) = r;;  (* -> escape *)
+let f (A r) = r.x;; (* ok *)
+let f x = A {x; y = x};; (* ok *)
+let f (A r) = A {r with y = r.x + 1};; (* ok *)
+let f () = A {a = 1};; (* customized error message *)
+let f () = A {x = 1; y = 3};; (* ok *)
+
+type _ t = A: {x : 'a; y : 'b} -> 'a t;;
+let f (A {x; y}) = A {x; y = ()};;  (* ok *)
+let f (A ({x; y} as r)) = A {x = r.x; y = r.y};; (* ok *)
+
+module M = struct
+  type 'a t =
+    | A of {x : 'a}
+    | B: {u : 'b} -> unit t;;
+
+  exception Foo of {x : int};;
+end;;
+
+module N : sig
+  type 'b t = 'b M.t =
+    | A of {x : 'b}
+    | B: {u : 'bla} -> unit t
+
+  exception Foo of {x : int}
+end = struct
+  type 'b t = 'b M.t =
+    | A of {x : 'b}
+    | B: {u : 'z} -> unit t
+
+  exception Foo = M.Foo
+end;;
+
+
+module type S = sig exception A of {x:int}  end;;
+
+module F (X : sig val x : (module S) end) = struct
+  module A = (val X.x)
+end;;  (* -> this expression creates fresh types (not really!) *)
+
+
+module type S = sig
+  exception A of {x : int}
+  exception A of {x : string}
+end;;
+
+module M = struct
+  exception A of {x : int}
+  exception A of {x : string}
+end;;
+
+
+module M1 = struct
+  exception A of {x : int}
+end;;
+
+module M = struct
+  include M1
+  include M1
+end;;
+
+
+module type S1 = sig
+  exception A of {x : int}
+end;;
+
+module type S = sig
+  include S1
+  include S1
+end;;
+
+module M = struct
+  exception A = M1.A
+end;;
+
+module X1 = struct
+  type t = ..
+end;;
+module X2 = struct
+  type t = ..
+end;;
+module Z = struct
+  type X1.t += A of {x: int}
+  type X2.t += A of {x: int}
+end;;
+
+(* PR#6716 *)
+
+type _ c = C : [`A] c
+type t = T : {x:[<`A] c} -> t;;
+let f (T { x = C }) = ();;
+module M : sig
+  type 'a t
+  type u = u t and v = v t
+  val f : int -> u
+  val g : v -> bool
+end = struct
+  type 'a t = 'a
+  type u = int and v = bool
+  let f x = x
+  let g x = x
+end;;
+
+let h (x : int) : bool = M.g (M.f x);;
+type _ t = C : ((('a -> 'o) -> 'o) -> ('b -> 'o) -> 'o) t
+let f : type a o. ((a -> o) -> o) t -> (a -> o) -> o =
+ fun C k -> k (fun x -> x);;
+module type T = sig type 'a t end
+module Fix (T : T) = struct type r = ('r T.t as 'r) end
+ type _ t =
+     X of string
+   | Y : bytes t
+
+let y : string t = Y
+let f : string A.t -> unit = function
+    A.X s -> print_endline s
+
+let () = f A.y
+module rec A : sig
+ type t
+end = struct
+ type t = { a : unit; b : unit }
+ let _ = { a = () }
+end
+;;
+type t = [`A | `B];;
+type 'a u = t;;
+let a : [< int u] = `A;;
+
+type 'a s = 'a;;
+let b : [< t s] = `B;;
+module Core = struct
+  module Int = struct
+    module T = struct
+      type t = int
+      let compare = compare
+      let (+) x y = x + y
+    end
+    include T
+    module Map = Map.Make(T)
+  end
+
+  module Std = struct
+    module Int = Int
+  end
+end
+;;
+
+open Core.Std
+;;
+
+let x = Int.Map.empty ;;
+let y = x + x ;;
+
+(* Avoid ambiguity *)
+
+module M = struct type t = A type u = C end
+module N = struct type t = B end
+open M open N;;
+A;;
+B;;
+C;;
+
+include M open M;;
+C;;
+
+module L = struct type v = V end
+open L;;
+V;;
+module L = struct type v = V end
+open L;;
+V;;
+
+
+type t1 = A;;
+module M1 = struct type u = v and v = t1 end;;
+module N1 = struct type u = v and v = M1.v end;;
+type t1 = B;;
+module N2 = struct type u = v and v = M1.v end;;
+
+
+(* PR#6566 *)
+module type PR6566 = sig type t = string end;;
+module PR6566 = struct type t = int end;;
+module PR6566' : PR6566 = PR6566;;
+
+module A = struct module B = struct type t = T end end;;
+module M2 = struct type u = A.B.t type foo = int type v = A.B.t end;;
+(* Adapted from: An Expressive Language of Signatures
+   by Norman Ramsey, Kathleen Fisher and Paul Govereau *)
+
+module type VALUE = sig
+  type value (* a Lua value *)
+  type state (* the state of a Lua interpreter *)
+  type usert (* a user-defined value *)
+end;;
+
+module type CORE0 = sig
+  module V : VALUE
+  val setglobal : V.state -> string -> V.value -> unit
+  (* five more functions common to core and evaluator *)
+end;;
+
+module type CORE = sig
+  include CORE0
+  val apply : V.value -> V.state -> V.value list -> V.value
+  (* apply function f in state s to list of args *)
+end;;
+
+module type AST = sig
+  module Value : VALUE
+  type chunk
+  type program
+  val get_value : chunk -> Value.value
+end;;
+
+module type EVALUATOR = sig
+  module Value : VALUE
+  module Ast : (AST with module Value := Value)
+  type state = Value.state
+  type value = Value.value
+  exception Error of string
+  val compile : Ast.program -> string
+  include CORE0 with module V := Value
+end;;
+
+module type PARSER = sig
+  type chunk
+  val parse : string -> chunk
+end;;
+
+module type INTERP = sig
+  include EVALUATOR
+  module Parser : PARSER with type chunk = Ast.chunk
+  val dostring : state -> string -> value list
+  val mk : unit -> state
+end;;
+
+module type USERTYPE = sig
+  type t
+  val eq : t -> t -> bool
+  val to_string : t -> string
+end;;
+
+module type TYPEVIEW = sig
+  type combined
+  type t
+  val map : (combined -> t) * (t -> combined)
+end;;
+
+module type COMBINED_COMMON = sig
+  module T : sig type t end
+  module TV1 : TYPEVIEW with type combined := T.t
+  module TV2 : TYPEVIEW with type combined := T.t
+end;;
+
+module type COMBINED_TYPE = sig
+  module T : USERTYPE
+  include COMBINED_COMMON with module T := T
+end;;
+
+module type BARECODE = sig
+  type state
+  val init : state -> unit
+end;;
+
+module USERCODE(X : TYPEVIEW) = struct
+  module type F =
+      functor (C : CORE with type V.usert = X.combined) ->
+        BARECODE with type state := C.V.state
+end;;
+
+module Weapon = struct type t end;;
+
+module type WEAPON_LIB = sig
+  type t = Weapon.t
+  module T : USERTYPE with type t = t
+  module Make :
+    functor (TV : TYPEVIEW with type t = t) -> USERCODE(TV).F
+end;;
+
+module type X = functor (X: CORE) -> BARECODE;;
+module type X = functor (_: CORE) -> BARECODE;;
+module M = struct
+  type t = int * (< m : 'a > as 'a)
+end;;
+
+module type S =
+    sig module M : sig type t end end with module M = M
+;;
+module type Printable = sig
+  type t
+  val print : Format.formatter -> t -> unit
+end;;
+module type Comparable = sig
+  type t
+  val compare : t -> t -> int
+end;;
+module type PrintableComparable = sig
+  include Printable
+  include Comparable with type t = t
+end;; (* Fails *)
+module type PrintableComparable = sig
+  type t
+  include Printable with type t := t
+  include Comparable with type t := t
+end;;
+module type PrintableComparable = sig
+  include Printable
+  include Comparable with type t := t
+end;;
+module type ComparableInt = Comparable with type t := int;;
+module type S = sig type t val f : t -> t end;;
+module type S' = S with type t := int;;
+
+module type S = sig type 'a t val map : ('a -> 'b) -> 'a t -> 'b t end;;
+module type S1 = S with type 'a t := 'a list;;
+module type S2 = sig
+  type 'a dict = (string * 'a) list
+  include S with type 'a t := 'a dict
+end;;
+
+
+module type S =
+  sig module T : sig type exp type arg end val f : T.exp -> T.arg end;;
+module M = struct type exp = string type arg = int end;;
+module type S' = S with module T := M;;
+
+
+module type S = sig type 'a t end with type 'a t := unit;; (* Fails *)
+let property (type t) () =
+  let module M = struct exception E of t end in
+  (fun x -> M.E x), (function M.E x -> Some x | _ -> None)
+;;
+
+let () =
+  let (int_inj, int_proj) = property () in
+  let (string_inj, string_proj) = property () in
+
+  let i = int_inj 3 in
+  let s = string_inj "abc" in
+
+  Printf.printf "%b\n%!" (int_proj i = None);
+  Printf.printf "%b\n%!" (int_proj s = None);
+  Printf.printf "%b\n%!" (string_proj i = None);
+  Printf.printf "%b\n%!" (string_proj s = None)
+;;
+
+let sort_uniq (type s) cmp l =
+  let module S = Set.Make(struct type t = s let compare = cmp end) in
+  S.elements (List.fold_right S.add l S.empty)
+;;
+
+let () =
+  print_endline (String.concat "," (sort_uniq compare [ "abc"; "xyz"; "abc" ]))
+;;
+
+let f x (type a) (y : a) = (x = y);; (* Fails *)
+class ['a] c = object (self)
+  method m : 'a -> 'a = fun x -> x
+  method n : 'a -> 'a = fun (type g) (x:g) -> self#m x
+end;; (* Fails *)
+
+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" "f_nat"
+
+module M : sig
+  external a : int -> (int [@untagged]) = "a" "a_nat"
+  external b : (int [@untagged]) -> int = "b" "b_nat"
+end = struct
+  external a : int -> (int [@untagged]) = "a" "a_nat"
+  external b : (int [@untagged]) -> int = "b" "b_nat"
+end;;
+
+module Global_attributes = struct
+  [@@@ocaml.warning "-3"]
+
+  external a : float -> float = "a" "noalloc" "a_nat" "float"
+  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 = "e"
+
+  (* Should output a warning: no native implementation provided *)
+  external f : (int32 [@unboxed]) -> (int32 [@unboxed]) = "f" "noalloc"
+  external g : int32 -> int32 = "g" "g_nat" [@@unboxed] [@@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
+  [@@@ocaml.warning "+3"]
+  external a : float -> float = "a" "noalloc" "a_nat" "float"
+  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" "f_nat"
+end = struct
+  external f : int -> (int [@untagged]) = "f" "f_nat"
+end;;
+
+module Bad2 : sig
+  external f : int -> int = "a" "a_nat"
+end = struct
+  external f : (int [@untagged]) -> int = "f" "f_nat"
+end;;
+
+module Bad3 : sig
+  external f : float -> float = "f" "f_nat"
+end = struct
+  external f : float -> (float [@unboxed]) = "f" "f_nat"
+end;;
+
+module Bad4 : sig
+  external f : float -> float = "a" "a_nat"
+end = struct
+  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" "f_nat"
+end = struct
+  external f : int -> int = "f" "f_nat"
+end;;
+
+module Bad6 : sig
+  external f : (int [@untagged]) -> int = "f" "f_nat"
+end = struct
+  external f : int -> int = "a" "a_nat"
+end;;
+
+module Bad7 : sig
+  external f : float -> (float [@unboxed]) = "f" "f_nat"
+end = struct
+  external f : float -> float = "f" "f_nat"
+end;;
+
+module Bad8 : sig
+  external f : (float [@unboxed]) -> float = "f" "f_nat"
+end = struct
+  external f : float -> float = "a" "a_nat"
+end;;
+
+(* Bad: unboxed or untagged with the wrong type *)
+
+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 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];;
+let _ = ignore (+);;
+let _ = raise Exit 3;;
+(* comment 9644 of PR#6000 *)
+
+fun b -> if b then format_of_string "x" else "y";;
+fun b -> if b then "x" else format_of_string "y";;
+fun b : (_,_,_) format -> if b then "x" else "y";;
+
+(* PR#7135 *)
+
+module PR7135 = struct
+  module M : sig type t = private int end =  struct type t = int end
+  include M
+
+  let lift2 (f : int -> int -> int) (x : t) (y : t) =
+    f (x :> int) (y :> int)
+end;;
+
+(* exemple of non-ground coercion *)
+
+module Test1 = struct
+  type t = private int
+  let f x = let y = if true then x else (x:t) in (y :> int)
+end;;
+(* Warn about all relevant cases when possible *)
+let f = function
+    None, None -> 1
+  | Some _, Some _ -> 2;;
+
+(* Exhaustiveness check is very slow *)
+type _ t =
+  A : int t | B : bool t | C : char t | D : float t
+type (_,_,_,_) u = U : (int, int, int, int) u
+type v = E | F | G
+;;
+
+let f : type a b c d e f g.
+      a t * b t * c t * d t * e t * f t * g t * v
+       * (a,b,c,d) u * (e,f,g,g) u -> int =
+ function A, A, A, A, A, A, A, _, U, U -> 1
+   | _, _, _, _, _, _, _, G, _, _ -> 1
+   (*| _ -> _ *)
+;;
+
+(* Unused cases *)
+let f (x : int t) = match x with A -> 1 | _ -> 2;; (* warn *)
+let f (x : unit t option) = match x with None -> 1 | _ -> 2 ;; (* warn? *)
+let f (x : unit t option) = match x with None -> 1 | Some _ -> 2 ;; (* warn *)
+let f (x : int t option) = match x with None -> 1 | _ -> 2;;
+let f (x : int t option) = match x with None -> 1;; (* warn *)
+
+(* Example with record, type, single case *)
+
+type 'a box = Box of 'a
+type 'a pair = {left: 'a; right: 'a};;
+
+let f : (int t box pair * bool) option -> unit = function None -> ();;
+let f : (string t box pair * bool) option -> unit = function None -> ();;
+
+
+(* Examples from ML2015 paper *)
+
+type _ t =
+  | Int : int t
+  | Bool : bool t
+;;
+
+let f : type a. a t -> a = function
+  | Int -> 1
+  | Bool -> true
+;;
+let g : int t -> int = function
+  | Int -> 1
+;;
+let h : type a. a t -> a t -> bool =
+  fun x y -> match x, y with
+  | Int, Int -> true
+  | Bool, Bool -> true
+;;
+type (_, _) cmp =
+ | Eq : ('a, 'a) cmp
+ | Any: ('a, 'b) cmp
+module A : sig type a type b val eq : (a, b) cmp end
+  = struct type a type b = a let eq = Eq end
+;;
+let f : (A.a, A.b) cmp -> unit = function Any -> ()
+;;
+let deep : char t option -> char =
+  function None -> 'c'
+;;
+type zero = Zero
+type _ succ = Succ
+;;
+type (_,_,_) plus =
+  | Plus0 : (zero, 'a, 'a) plus
+  | PlusS : ('a, 'b, 'c) plus ->
+       ('a succ, 'b, 'c succ) plus
+;;
+let trivial : (zero succ, zero, zero) plus option -> bool =
+  function None -> false
+;;
+let easy : (zero, zero succ, zero) plus option -> bool =
+  function None -> false
+;;
+let harder : (zero succ, zero succ, zero succ) plus option -> bool =
+  function None -> false
+;;
+let harder : (zero succ, zero succ, zero succ) plus option  -> bool =
+  function None -> false | Some (PlusS _) -> .
+;;
+let inv_zero : type a b c d. (a,b,c) plus -> (c,d,zero) plus -> bool =
+  fun p1 p2 ->
+    match p1, p2 with
+    | Plus0, Plus0 -> true
+;;
+
+
+(* Empty match *)
+
+type _ t = Int : int t;;
+let f (x : bool t) = match x with _ -> . ;; (* ok *)
+
+
+(* trefis in PR#6437 *)
+
+let f () = match None with _ -> .;; (* error *)
+let g () = match None with _ -> () | exception _ -> .;; (* error *)
+let h () = match None with _ -> .  | exception _ -> .;; (* error *)
+let f x = match x with _ -> () | None -> .;; (* do not warn *)
+
+(* #7059, all clauses guarded *)
+
+let f x y = match 1 with 1 when x = y -> 1;;
+open CamlinternalOO;;
+type _ choice = Left : label choice | Right : tag choice;;
+let f : label choice -> bool = function Left -> true;; (* warn *)
+exception A;;
+type a = A;;
+
+A;;
+raise A;;
+fun (A : a) -> ();;
+function Not_found -> 1 | A -> 2 | _ -> 3;;
+try raise A with A -> 2;;
+module TypEq = struct
+ type (_, _) t = Eq : ('a, 'a) t
+end
+
+module type T = sig
+ type _ is_t = Is : ('a, 'b) TypEq.t -> 'a is_t
+ val is_t : unit -> unit is_t option
+end
+
+module Make (M : T) =
+ struct
+   let _ =
+     match M.is_t () with
+     | None -> 0
+     | Some _ -> 0
+   let f () =
+     match M.is_t () with None -> 0
+end;;
+
+module Make2 (M : T) = struct
+  type t = T of unit M.is_t
+  let g : t -> int = function _ -> .
+end;;
+type t = A : t;;
+
+module X1 : sig end = struct
+  let _f ~x (* x unused argument *) = function
+    | A -> let x = () in x
+end;;
+
+module X2 : sig end = struct
+  let x = 42 (* unused value *)
+  let _f = function
+    | A -> let x = () in x
+end;;
+
+module X3 : sig end = struct
+  module O = struct let x = 42 (* unused *) end
+  open O (* unused open *)
+
+  let _f = function
+    | A -> let x = () in x
+end;;
+(* Use type information *)
+module M1 = struct
+  type t = {x: int; y: int}
+  type u = {x: bool; y: bool}
+end;;
+
+module OK = struct
+  open M1
+  let f1 (r:t) = r.x (* ok *)
+  let f2 r = ignore (r:t); r.x (* non principal *)
+
+  let f3 (r: t) =
+    match r with {x; y} -> y + y (* ok *)
+end;;
+
+module F1 = struct
+  open M1
+  let f r = match r with {x; y} -> y + y
+end;; (* fails *)
+
+module F2 = struct
+  open M1
+  let f r =
+    ignore (r: t);
+    match r with
+       {x; y} -> y + y
+end;; (* fails for -principal *)
+
+(* Use type information with modules*)
+module M = struct
+  type t = {x:int}
+  type u = {x:bool}
+end;;
+let f (r:M.t) = r.M.x;; (* ok *)
+let f (r:M.t) = r.x;; (* warning *)
+let f ({x}:M.t) = x;; (* warning *)
+
+module M = struct
+  type t = {x: int; y: int}
+end;;
+module N = struct
+  type u = {x: bool; y: bool}
+end;;
+module OK = struct
+  open M
+  open N
+  let f (r:M.t) = r.x
+end;;
+
+module M = struct
+  type t = {x:int}
+  module N = struct type s = t = {x:int} end
+  type u = {x:bool}
+end;;
+module OK = struct
+  open M.N
+  let f (r:M.t) = r.x
+end;;
+
+(* Use field information *)
+module M = struct
+  type u = {x:bool;y:int;z:char}
+  type t = {x:int;y:bool}
+end;;
+module OK = struct
+  open M
+  let f {x;z} = x,z
+end;; (* ok *)
+module F3 = struct
+  open M
+  let r = {x=true;z='z'}
+end;; (* fail for missing label *)
+
+module OK = struct
+  type u = {x:int;y:bool}
+  type t = {x:bool;y:int;z:char}
+  let r = {x=3; y=true}
+end;; (* ok *)
+
+(* Corner cases *)
+
+module F4 = struct
+  type foo = {x:int; y:int}
+  type bar = {x:int}
+  let b : bar = {x=3; y=4}
+end;; (* fail but don't warn *)
+
+module M = struct type foo = {x:int;y:int} end;;
+module N = struct type bar = {x:int;y:int} end;;
+let r = { M.x = 3; N.y = 4; };; (* error: different definitions *)
+
+module MN = struct include M include N end
+module NM = struct include N include M end;;
+let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+
+(* Lpw25 *)
+
+module M = struct
+  type foo = { x: int; y: int }
+  type bar = { x:int; y: int; z: int}
+end;;
+module F5 = struct
+  open M
+  let f r = ignore (r: foo); {r with x = 2; z = 3}
+end;;
+module M = struct
+  include M
+  type other = { a: int; b: int }
+end;;
+module F6 = struct
+  open M
+  let f r = ignore (r: foo); { r with x = 3; a = 4 }
+end;;
+module F7 = struct
+  open M
+  let r = {x=1; y=2}
+  let r: other = {x=1; y=2}
+end;;
+
+module A = struct type t = {x: int} end
+module B = struct type t = {x: int} end;;
+let f (r : B.t) = r.A.x;; (* fail *)
+
+(* Spellchecking *)
+
+module F8 = struct
+  type t = {x:int; yyy:int}
+  let a : t = {x=1;yyz=2}
+end;;
+
+(* PR#6004 *)
+
+type t = A
+type s = A
+
+class f (_ : t) = object end;;
+class g = f A;; (* ok *)
+
+class f (_ : 'a) (_ : 'a) = object end;;
+class g = f (A : t) A;; (* warn with -principal *)
+
+
+(* PR#5980 *)
+
+module Shadow1 = struct
+  type t = {x: int}
+  module M = struct
+    type s = {x: string}
+  end
+  open M  (* this open is unused, it isn't reported as shadowing 'x' *)
+  let y : t = {x = 0}
+end;;
+module Shadow2 = struct
+  type t = {x: int}
+  module M = struct
+    type s = {x: string}
+  end
+  open M  (* this open shadows label 'x' *)
+  let y = {x = ""}
+end;;
+
+(* PR#6235 *)
+
+module P6235 = struct
+  type t = { loc : string; }
+  type v = { loc : string; x : int; }
+  type u = [ `Key of t ]
+  let f (u : u) = match u with `Key {loc} -> loc
+end;;
+
+(* Remove interaction between branches *)
+
+module P6235' = struct
+  type t = { loc : string; }
+  type v = { loc : string; x : int; }
+  type u = [ `Key of t ]
+  let f = function
+    | (_ : u) when false -> ""
+    |`Key {loc} -> loc
+end;;
+module Unused : sig
+end = struct
+  type unused = int
+end
+;;
+
+module Unused_nonrec : sig
+end = struct
+  type nonrec used = int
+  type nonrec unused = used
+end
+;;
+
+module Unused_rec : sig
+end = struct
+  type unused = A of unused
+end
+;;
+
+module Unused_exception : sig
+end = struct
+  exception Nobody_uses_me
+end
+;;
+
+module Unused_extension_constructor : sig
+  type t = ..
+end = struct
+  type t = ..
+  type t += Nobody_uses_me
+end
+;;
+
+module Unused_exception_outside_patterns : sig
+  val falsity : exn -> bool
+end = struct
+  exception Nobody_constructs_me
+  let falsity = function
+    | Nobody_constructs_me -> true
+    | _ -> false
+end
+;;
+
+module Unused_extension_outside_patterns : sig
+  type t = ..
+  val falsity : t -> bool
+end = struct
+  type t = ..
+  type t += Nobody_constructs_me
+  let falsity = function
+    | Nobody_constructs_me -> true
+    | _ -> false
+end
+;;
+
+module Unused_private_exception : sig
+  type exn += private Private_exn
+end = struct
+  exception Private_exn
+end
+;;
+
+module Unused_private_extension : sig
+  type t = ..
+  type t += private Private_ext
+end = struct
+  type t = ..
+  type t += Private_ext
+end
+;;
+
+for i = 10 downto 0 do () done
+
+type t = < foo: int [@foo] >
+
+let _ = [%foo: < foo : t > ]
+
+type foo += private A of int
+
+let f : 'a 'b 'c. < .. > = assert false
+
+let () =
+  let module M = (functor (T : sig end) -> struct end)(struct end) in ()
+
+class c = object inherit ((fun () -> object end [@wee]: object end) ()) end
+
+
+let f = function x[@wee] -> ()
+let f = function
+  | '1'..'9' | '1' .. '8'-> ()
+  | 'a'..'z' -> ()
+
+let f = function
+  | [| x1; x2 |] -> ()
+  | [| |] -> ()
+  | [|x|][@foo] -> ()
+  | _ -> ()
+
+let g = function
+  | {l=x} -> ()
+  | {l1=x; l2=y}[@foo] -> ()
+  | {l1=x; l2=y; _} -> ()
+
+let h = fun ?l:(p=1) ?y:u ?x:(x=3) -> 2
+
+let _ = function
+  | a, s, ba1, ba2, ba3, bg -> begin
+      ignore (Array.get x 1 + Array.get [| |] 0 +
+              Array.get [| 1 |] 1 + Array.get [|1; 2|] 2);
+      ignore ([String.get s 1; String.get "" 2; String.get "123" 3]);
+      ignore (ba1.{0} + ba2.{1, 2} + ba3.{3, 4, 5})
+      ignore (bg.{1, 2, 3, 4})
+    end
+  | b, s, ba1, ba2, ba3, bg -> begin
+      y.(0) <- 1; s.[1] <- 'c';
+      ba1.{1} <- 2; ba2.{1, 2} <- 3; ba3.{1, 2, 3} <- 4;
+      bg.{1, 2, 3, 4, 5} <- 0
+    end
+
+let f (type t) () =
+  let exception F of t in ();
+  let exception G of t in ();
+  let exception E of t in
+  (fun x -> E x), (function E _ -> print_endline "OK" | _ -> print_endline "KO")
+
+let inj1, proj1 = f ()
+let inj2, proj2 = f ()
+
+let () = proj1 (inj1 42)
+let () = proj1 (inj2 42)
+
+let _ = ~-1
+
+class id = [%exp]
+(* checkpoint *)
+
+(* Subtyping is "syntactic" *)
+let _ = fun (x : < x : int >) y z -> (y :> 'a), (x :> 'a), (z :> 'a);;
+(* - : (< x : int > as 'a) -> 'a -> 'a * 'a =  *)
+
+(*
+class ['a] c () = object
+  method f = (new c (): int c)
+end and ['a] d () = object
+  inherit ['a] c ()
+end;;
+*)
+
+(* PR#7329 Pattern open *)
+let _ =
+  let module M = struct type t = { x : int } end in
+  let f M.(x) = () in
+  let g M.{x} = () in
+  let h = function M.[] | M.[a] | M.(a::q) -> () in
+  let i = function M.[||] | M.[|x|]  -> true | _ -> false in
+  ()
diff --git a/testsuite/tests/parsetree/test.ml b/testsuite/tests/parsetree/test.ml
new file mode 100644
index 00000000..ba8819db
--- /dev/null
+++ b/testsuite/tests/parsetree/test.ml
@@ -0,0 +1,102 @@
+(* (c) Alain Frisch / Lexifi *)
+(* cf. PR#7200 *)
+let report_err exn =
+  match exn with
+    | Sys_error msg ->
+        Format.printf "@[I/O error:@ %s@]@." msg
+    | x ->
+        match Location.error_of_exn x with
+        | Some err ->
+            Format.printf "@[%a@]@."
+              Location.report_error err
+        | None -> raise x
+
+let remove_locs =
+  let open Ast_mapper in
+  { default_mapper with
+    location = (fun _mapper _loc -> Location.none);
+    attributes =
+      (fun mapper attrs ->
+         let attrs = default_mapper.attributes mapper attrs in
+         List.filter (fun (s, _) -> s.Location.txt <> "#punning#")
+           attrs (* this is to accomodate a LexiFi custom extension *)
+      )
+  }
+
+let from_file parse_fun filename =
+  Location.input_name := filename;
+  let ic = open_in filename in
+  let lexbuf = Lexing.from_channel ic in
+  Location.init lexbuf filename;
+  let ast = parse_fun lexbuf in
+  close_in ic;
+  ast
+
+let from_string parse_fun str =
+  Location.input_name := "";
+  let lexbuf = Lexing.from_string str in
+  Location.init lexbuf "";
+  parse_fun lexbuf
+
+let to_string print_fun ast =
+  Format.fprintf Format.str_formatter "%a@." print_fun ast;
+  Format.flush_str_formatter ()
+
+let to_tmp_file print_fun ast =
+  let fn, oc = Filename.open_temp_file "ocamlparse" ".txt" in
+  output_string oc (to_string print_fun ast);
+  close_out oc;
+  fn
+
+let test parse_fun pprint print map filename =
+  match from_file parse_fun filename with
+  | exception exn ->
+      Printf.printf "%s: FAIL, CANNOT PARSE\n" filename;
+      report_err exn;
+      print_endline "====================================================="
+  | ast ->
+      let str = to_string pprint ast in
+      match from_string parse_fun str with
+      | exception exn ->
+          Printf.printf "%s: FAIL, CANNOT REPARSE\n" filename;
+          report_err exn;
+          print_endline str;
+          print_endline "====================================================="
+      | ast2 ->
+          let ast = map remove_locs remove_locs ast in
+          let ast2 = map remove_locs remove_locs ast2 in
+          if ast <> ast2 then begin
+            Printf.printf "%s:  FAIL, REPARSED AST IS DIFFERENT\n%!" filename;
+            let f1 = to_tmp_file print ast in
+            let f2 = to_tmp_file print ast2 in
+            let cmd = Printf.sprintf "diff -u %s %s"
+                (Filename.quote f1) (Filename.quote f2) in
+            let _ret = Sys.command cmd in
+            print_endline"====================================================="
+          end
+
+let test parse_fun pprint print map filename =
+  try test parse_fun pprint print map filename
+  with exn -> report_err exn
+
+let rec process path =
+  if Sys.is_directory path then
+    let files = Sys.readdir path in
+    Array.iter (fun s -> process (Filename.concat path s)) files
+  else if Filename.check_suffix path ".ml" then
+    test
+      Parse.implementation
+      Pprintast.structure
+      Printast.implementation
+      (fun mapper -> mapper.Ast_mapper.structure)
+      path
+  else if Filename.check_suffix path ".mli" then
+    test
+      Parse.interface
+      Pprintast.signature
+      Printast.interface
+      (fun mapper -> mapper.Ast_mapper.signature)
+      path
+
+let () =
+  process "source.ml"
diff --git a/testsuite/tests/parsetree/test.reference b/testsuite/tests/parsetree/test.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/parsing/extensions.ml.reference b/testsuite/tests/parsing/extensions.ml.reference
index bd14c5d3..e904d7e9 100644
--- a/testsuite/tests/parsing/extensions.ml.reference
+++ b/testsuite/tests/parsing/extensions.ml.reference
@@ -323,4 +323,4 @@
 ]
 
 File "extensions.ml", line 2, characters 3-6:
-Uninterpreted extension 'foo'.
+Error: Uninterpreted extension 'foo'.
diff --git a/testsuite/tests/parsing/pr6865.ml.reference b/testsuite/tests/parsing/pr6865.ml.reference
index 55a541fb..72abd40e 100644
--- a/testsuite/tests/parsing/pr6865.ml.reference
+++ b/testsuite/tests/parsing/pr6865.ml.reference
@@ -49,4 +49,4 @@
 ]
 
 File "pr6865.ml", line 1, characters 4-7:
-Uninterpreted extension 'foo'.
+Error: Uninterpreted extension 'foo'.
diff --git a/testsuite/tests/parsing/pr7165.ml b/testsuite/tests/parsing/pr7165.ml
new file mode 100644
index 00000000..ba6835b4
--- /dev/null
+++ b/testsuite/tests/parsing/pr7165.ml
@@ -0,0 +1,4 @@
+(* this is a lexer directive with an out-of-bound integer;
+   it should result in a lexing error instead of an
+   uncaught exception as in PR#7165 *)
+#9342101923012312312
diff --git a/testsuite/tests/parsing/pr7165.ml.reference b/testsuite/tests/parsing/pr7165.ml.reference
new file mode 100644
index 00000000..fd59df84
--- /dev/null
+++ b/testsuite/tests/parsing/pr7165.ml.reference
@@ -0,0 +1,2 @@
+File "pr7165.ml", line 4, characters 0-21:
+Error: Invalid lexer directive "#9342101923012312312": line number out of range
diff --git a/testsuite/tests/parsing/shortcut_ext_attr.ml b/testsuite/tests/parsing/shortcut_ext_attr.ml
index e65a663c..7f6d1f51 100644
--- a/testsuite/tests/parsing/shortcut_ext_attr.ml
+++ b/testsuite/tests/parsing/shortcut_ext_attr.ml
@@ -11,6 +11,7 @@ let () =
   (if%foo[@foo] () then () else ()) ;
   while%foo[@foo] () do () done ;
   for%foo[@foo] x = () to () do () done ;
+  () ;%foo () ;
   assert%foo[@foo] true ;
   lazy%foo[@foo] x ;
   object%foo[@foo] end ;
diff --git a/testsuite/tests/parsing/shortcut_ext_attr.ml.reference b/testsuite/tests/parsing/shortcut_ext_attr.ml.reference
index 27c32e16..c3101349 100644
--- a/testsuite/tests/parsing/shortcut_ext_attr.ml.reference
+++ b/testsuite/tests/parsing/shortcut_ext_attr.ml.reference
@@ -1,17 +1,17 @@
 [
-  structure_item (shortcut_ext_attr.ml[3,19+0]..[23,554+31])
+  structure_item (shortcut_ext_attr.ml[3,19+0]..[24,570+31])
     Pstr_value Nonrec
     [
       
         pattern (shortcut_ext_attr.ml[3,19+4]..[3,19+6])
           Ppat_construct "()" (shortcut_ext_attr.ml[3,19+4]..[3,19+6])
           None
-        expression (shortcut_ext_attr.ml[4,28+2]..[23,554+31]) ghost
+        expression (shortcut_ext_attr.ml[4,28+2]..[24,570+31]) ghost
           Pexp_extension "foo"
           [
-            structure_item (shortcut_ext_attr.ml[4,28+2]..[23,554+31])
+            structure_item (shortcut_ext_attr.ml[4,28+2]..[24,570+31])
               Pstr_eval
-              expression (shortcut_ext_attr.ml[4,28+2]..[23,554+31])
+              expression (shortcut_ext_attr.ml[4,28+2]..[24,570+31])
                 Pexp_let Nonrec
                 [
                   
@@ -29,7 +29,7 @@
                     expression (shortcut_ext_attr.ml[5,50+16]..[5,50+17])
                       Pexp_constant PConst_int (4,None)
                 ]
-                expression (shortcut_ext_attr.ml[6,71+2]..[23,554+31])
+                expression (shortcut_ext_attr.ml[6,71+2]..[24,570+31])
                   Pexp_sequence
                   expression (shortcut_ext_attr.ml[6,71+2]..[6,71+36])
                     Pexp_extension "foo"
@@ -46,7 +46,7 @@
                             Pexp_construct "()" (shortcut_ext_attr.ml[6,71+33]..[6,71+35])
                             None
                     ]
-                  expression (shortcut_ext_attr.ml[7,110+2]..[23,554+31])
+                  expression (shortcut_ext_attr.ml[7,110+2]..[24,570+31])
                     Pexp_sequence
                     expression (shortcut_ext_attr.ml[7,110+2]..[7,110+30])
                       Pexp_extension "foo"
@@ -61,7 +61,7 @@
                               Pexp_construct "()" (shortcut_ext_attr.ml[7,110+27]..[7,110+29])
                               None
                       ]
-                    expression (shortcut_ext_attr.ml[8,143+2]..[23,554+31])
+                    expression (shortcut_ext_attr.ml[8,143+2]..[24,570+31])
                       Pexp_sequence
                       expression (shortcut_ext_attr.ml[8,143+2]..[8,143+25])
                         Pexp_extension "foo"
@@ -80,7 +80,7 @@
                                 Pexp_construct "()" (shortcut_ext_attr.ml[8,143+22]..[8,143+24])
                                 None
                         ]
-                      expression (shortcut_ext_attr.ml[9,171+2]..[23,554+31])
+                      expression (shortcut_ext_attr.ml[9,171+2]..[24,570+31])
                         Pexp_sequence
                         expression (shortcut_ext_attr.ml[9,171+2]..[9,171+30])
                           Pexp_extension "foo"
@@ -100,7 +100,7 @@
                                       None
                                 ]
                           ]
-                        expression (shortcut_ext_attr.ml[10,204+2]..[23,554+31])
+                        expression (shortcut_ext_attr.ml[10,204+2]..[24,570+31])
                           Pexp_sequence
                           expression (shortcut_ext_attr.ml[10,204+2]..[10,204+33])
                             Pexp_extension "foo"
@@ -123,7 +123,7 @@
                                         None
                                   ]
                             ]
-                          expression (shortcut_ext_attr.ml[11,240+2]..[23,554+31])
+                          expression (shortcut_ext_attr.ml[11,240+2]..[24,570+31])
                             Pexp_sequence
                             expression (shortcut_ext_attr.ml[11,240+2]..[11,240+35])
                               Pexp_extension "foo"
@@ -145,7 +145,7 @@
                                         Pexp_construct "()" (shortcut_ext_attr.ml[11,240+32]..[11,240+34])
                                         None
                               ]
-                            expression (shortcut_ext_attr.ml[12,278+2]..[23,554+31])
+                            expression (shortcut_ext_attr.ml[12,278+2]..[24,570+31])
                               Pexp_sequence
                               expression (shortcut_ext_attr.ml[12,278+2]..[12,278+31]) ghost
                                 Pexp_extension "foo"
@@ -163,7 +163,7 @@
                                         Pexp_construct "()" (shortcut_ext_attr.ml[12,278+24]..[12,278+26])
                                         None
                                 ]
-                              expression (shortcut_ext_attr.ml[13,312+2]..[23,554+31])
+                              expression (shortcut_ext_attr.ml[13,312+2]..[24,570+31])
                                 Pexp_sequence
                                 expression (shortcut_ext_attr.ml[13,312+2]..[13,312+39]) ghost
                                   Pexp_extension "foo"
@@ -186,292 +186,308 @@
                                           Pexp_construct "()" (shortcut_ext_attr.ml[13,312+32]..[13,312+34])
                                           None
                                   ]
-                                expression (shortcut_ext_attr.ml[14,354+2]..[23,554+31])
-                                  Pexp_sequence
-                                  expression (shortcut_ext_attr.ml[14,354+2]..[14,354+23]) ghost
-                                    Pexp_extension "foo"
-                                    [
-                                      structure_item (shortcut_ext_attr.ml[14,354+2]..[14,354+23])
-                                        Pstr_eval
-                                        expression (shortcut_ext_attr.ml[14,354+2]..[14,354+23])
-                                          attribute "foo"
-                                            []
-                                          Pexp_assert
-                                          expression (shortcut_ext_attr.ml[14,354+19]..[14,354+23])
-                                            Pexp_construct "true" (shortcut_ext_attr.ml[14,354+19]..[14,354+23])
-                                            None
-                                    ]
-                                  expression (shortcut_ext_attr.ml[15,380+2]..[23,554+31])
-                                    Pexp_sequence
-                                    expression (shortcut_ext_attr.ml[15,380+2]..[15,380+18]) ghost
-                                      Pexp_extension "foo"
-                                      [
-                                        structure_item (shortcut_ext_attr.ml[15,380+2]..[15,380+18])
-                                          Pstr_eval
-                                          expression (shortcut_ext_attr.ml[15,380+2]..[15,380+18])
-                                            attribute "foo"
-                                              []
-                                            Pexp_lazy
-                                            expression (shortcut_ext_attr.ml[15,380+17]..[15,380+18])
-                                              Pexp_ident "x" (shortcut_ext_attr.ml[15,380+17]..[15,380+18])
-                                      ]
-                                    expression (shortcut_ext_attr.ml[16,401+2]..[23,554+31])
-                                      Pexp_sequence
-                                      expression (shortcut_ext_attr.ml[16,401+2]..[16,401+22]) ghost
-                                        Pexp_extension "foo"
-                                        [
-                                          structure_item (shortcut_ext_attr.ml[16,401+2]..[16,401+22])
-                                            Pstr_eval
-                                            expression (shortcut_ext_attr.ml[16,401+2]..[16,401+22])
-                                              attribute "foo"
-                                                []
-                                              Pexp_object
-                                              class_structure
-                                                pattern (shortcut_ext_attr.ml[16,401+18]..[16,401+18]) ghost
-                                                  Ppat_any
-                                                []
-                                        ]
-                                      expression (shortcut_ext_attr.ml[17,426+2]..[23,554+31])
+                                expression (shortcut_ext_attr.ml[14,354+2]..[24,570+31])
+                                  Pexp_extension "foo"
+                                  [
+                                    structure_item (shortcut_ext_attr.ml[14,354+2]..[24,570+31])
+                                      Pstr_eval
+                                      expression (shortcut_ext_attr.ml[14,354+2]..[24,570+31])
                                         Pexp_sequence
-                                        expression (shortcut_ext_attr.ml[17,426+2]..[17,426+23]) ghost
-                                          Pexp_extension "foo"
-                                          [
-                                            structure_item (shortcut_ext_attr.ml[17,426+2]..[17,426+23])
-                                              Pstr_eval
-                                              expression (shortcut_ext_attr.ml[17,426+2]..[17,426+23])
-                                                attribute "foo"
-                                                  []
-                                                Pexp_constant PConst_int (3,None)
-                                          ]
-                                        expression (shortcut_ext_attr.ml[18,452+2]..[23,554+31])
+                                        expression (shortcut_ext_attr.ml[14,354+2]..[14,354+4])
+                                          Pexp_construct "()" (shortcut_ext_attr.ml[14,354+2]..[14,354+4])
+                                          None
+                                        expression (shortcut_ext_attr.ml[14,354+11]..[24,570+31])
                                           Pexp_sequence
-                                          expression (shortcut_ext_attr.ml[18,452+2]..[18,452+17]) ghost
-                                            Pexp_extension "foo"
-                                            [
-                                              structure_item (shortcut_ext_attr.ml[18,452+2]..[18,452+17])
-                                                Pstr_eval
-                                                expression (shortcut_ext_attr.ml[18,452+2]..[18,452+17])
-                                                  attribute "foo"
-                                                    []
-                                                  Pexp_new "x" (shortcut_ext_attr.ml[18,452+16]..[18,452+17])
-                                            ]
-                                          expression (shortcut_ext_attr.ml[20,473+2]..[23,554+31]) ghost
-                                            Pexp_extension "foo"
-                                            [
-                                              structure_item (shortcut_ext_attr.ml[20,473+2]..[23,554+31])
-                                                Pstr_eval
-                                                expression (shortcut_ext_attr.ml[20,473+2]..[23,554+31])
-                                                  attribute "foo"
-                                                    []
-                                                  Pexp_match
-                                                  expression (shortcut_ext_attr.ml[20,473+18]..[20,473+20])
-                                                    Pexp_construct "()" (shortcut_ext_attr.ml[20,473+18]..[20,473+20])
-                                                    None
+                                          expression (shortcut_ext_attr.ml[14,354+11]..[14,354+13])
+                                            Pexp_construct "()" (shortcut_ext_attr.ml[14,354+11]..[14,354+13])
+                                            None
+                                          expression (shortcut_ext_attr.ml[15,370+2]..[24,570+31])
+                                            Pexp_sequence
+                                            expression (shortcut_ext_attr.ml[15,370+2]..[15,370+23]) ghost
+                                              Pexp_extension "foo"
+                                              [
+                                                structure_item (shortcut_ext_attr.ml[15,370+2]..[15,370+23])
+                                                  Pstr_eval
+                                                  expression (shortcut_ext_attr.ml[15,370+2]..[15,370+23])
+                                                    attribute "foo"
+                                                      []
+                                                    Pexp_assert
+                                                    expression (shortcut_ext_attr.ml[15,370+19]..[15,370+23])
+                                                      Pexp_construct "true" (shortcut_ext_attr.ml[15,370+19]..[15,370+23])
+                                                      None
+                                              ]
+                                            expression (shortcut_ext_attr.ml[16,396+2]..[24,570+31])
+                                              Pexp_sequence
+                                              expression (shortcut_ext_attr.ml[16,396+2]..[16,396+18]) ghost
+                                                Pexp_extension "foo"
+                                                [
+                                                  structure_item (shortcut_ext_attr.ml[16,396+2]..[16,396+18])
+                                                    Pstr_eval
+                                                    expression (shortcut_ext_attr.ml[16,396+2]..[16,396+18])
+                                                      attribute "foo"
+                                                        []
+                                                      Pexp_lazy
+                                                      expression (shortcut_ext_attr.ml[16,396+17]..[16,396+18])
+                                                        Pexp_ident "x" (shortcut_ext_attr.ml[16,396+17]..[16,396+18])
+                                                ]
+                                              expression (shortcut_ext_attr.ml[17,417+2]..[24,570+31])
+                                                Pexp_sequence
+                                                expression (shortcut_ext_attr.ml[17,417+2]..[17,417+22]) ghost
+                                                  Pexp_extension "foo"
                                                   [
-                                                    
-                                                      pattern (shortcut_ext_attr.ml[22,527+4]..[22,527+20]) ghost
-                                                        Ppat_extension "foo"
-                                                        pattern (shortcut_ext_attr.ml[22,527+4]..[22,527+20])
-                                                          attribute "foo"
-                                                            []
-                                                          Ppat_lazy
-                                                          pattern (shortcut_ext_attr.ml[22,527+19]..[22,527+20])
-                                                            Ppat_var "x" (shortcut_ext_attr.ml[22,527+19]..[22,527+20])
-                                                      expression (shortcut_ext_attr.ml[22,527+24]..[22,527+26])
-                                                        Pexp_construct "()" (shortcut_ext_attr.ml[22,527+24]..[22,527+26])
-                                                        None
-                                                    
-                                                      pattern (shortcut_ext_attr.ml[23,554+4]..[23,554+25]) ghost
-                                                        Ppat_extension "foo"
-                                                        pattern (shortcut_ext_attr.ml[23,554+4]..[23,554+25])
+                                                    structure_item (shortcut_ext_attr.ml[17,417+2]..[17,417+22])
+                                                      Pstr_eval
+                                                      expression (shortcut_ext_attr.ml[17,417+2]..[17,417+22])
+                                                        attribute "foo"
+                                                          []
+                                                        Pexp_object
+                                                        class_structure
+                                                          pattern (shortcut_ext_attr.ml[17,417+18]..[17,417+18]) ghost
+                                                            Ppat_any
+                                                          []
+                                                  ]
+                                                expression (shortcut_ext_attr.ml[18,442+2]..[24,570+31])
+                                                  Pexp_sequence
+                                                  expression (shortcut_ext_attr.ml[18,442+2]..[18,442+23]) ghost
+                                                    Pexp_extension "foo"
+                                                    [
+                                                      structure_item (shortcut_ext_attr.ml[18,442+2]..[18,442+23])
+                                                        Pstr_eval
+                                                        expression (shortcut_ext_attr.ml[18,442+2]..[18,442+23])
                                                           attribute "foo"
                                                             []
-                                                          Ppat_exception
-                                                          pattern (shortcut_ext_attr.ml[23,554+24]..[23,554+25])
-                                                            Ppat_var "x" (shortcut_ext_attr.ml[23,554+24]..[23,554+25])
-                                                      expression (shortcut_ext_attr.ml[23,554+29]..[23,554+31])
-                                                        Pexp_construct "()" (shortcut_ext_attr.ml[23,554+29]..[23,554+31])
-                                                        None
-                                                  ]
-                                            ]
+                                                          Pexp_constant PConst_int (3,None)
+                                                    ]
+                                                  expression (shortcut_ext_attr.ml[19,468+2]..[24,570+31])
+                                                    Pexp_sequence
+                                                    expression (shortcut_ext_attr.ml[19,468+2]..[19,468+17]) ghost
+                                                      Pexp_extension "foo"
+                                                      [
+                                                        structure_item (shortcut_ext_attr.ml[19,468+2]..[19,468+17])
+                                                          Pstr_eval
+                                                          expression (shortcut_ext_attr.ml[19,468+2]..[19,468+17])
+                                                            attribute "foo"
+                                                              []
+                                                            Pexp_new "x" (shortcut_ext_attr.ml[19,468+16]..[19,468+17])
+                                                      ]
+                                                    expression (shortcut_ext_attr.ml[21,489+2]..[24,570+31]) ghost
+                                                      Pexp_extension "foo"
+                                                      [
+                                                        structure_item (shortcut_ext_attr.ml[21,489+2]..[24,570+31])
+                                                          Pstr_eval
+                                                          expression (shortcut_ext_attr.ml[21,489+2]..[24,570+31])
+                                                            attribute "foo"
+                                                              []
+                                                            Pexp_match
+                                                            expression (shortcut_ext_attr.ml[21,489+18]..[21,489+20])
+                                                              Pexp_construct "()" (shortcut_ext_attr.ml[21,489+18]..[21,489+20])
+                                                              None
+                                                            [
+                                                              
+                                                                pattern (shortcut_ext_attr.ml[23,543+4]..[23,543+20]) ghost
+                                                                  Ppat_extension "foo"
+                                                                  pattern (shortcut_ext_attr.ml[23,543+4]..[23,543+20])
+                                                                    attribute "foo"
+                                                                      []
+                                                                    Ppat_lazy
+                                                                    pattern (shortcut_ext_attr.ml[23,543+19]..[23,543+20])
+                                                                      Ppat_var "x" (shortcut_ext_attr.ml[23,543+19]..[23,543+20])
+                                                                expression (shortcut_ext_attr.ml[23,543+24]..[23,543+26])
+                                                                  Pexp_construct "()" (shortcut_ext_attr.ml[23,543+24]..[23,543+26])
+                                                                  None
+                                                              
+                                                                pattern (shortcut_ext_attr.ml[24,570+4]..[24,570+25]) ghost
+                                                                  Ppat_extension "foo"
+                                                                  pattern (shortcut_ext_attr.ml[24,570+4]..[24,570+25])
+                                                                    attribute "foo"
+                                                                      []
+                                                                    Ppat_exception
+                                                                    pattern (shortcut_ext_attr.ml[24,570+24]..[24,570+25])
+                                                                      Ppat_var "x" (shortcut_ext_attr.ml[24,570+24]..[24,570+25])
+                                                                expression (shortcut_ext_attr.ml[24,570+29]..[24,570+31])
+                                                                  Pexp_construct "()" (shortcut_ext_attr.ml[24,570+29]..[24,570+31])
+                                                                  None
+                                                            ]
+                                                      ]
+                                  ]
           ]
     ]
-  structure_item (shortcut_ext_attr.ml[27,612+0]..[39,882+5])
+  structure_item (shortcut_ext_attr.ml[28,628+0]..[40,898+5])
     Pstr_class
     [
-      class_declaration (shortcut_ext_attr.ml[27,612+0]..[39,882+5])
+      class_declaration (shortcut_ext_attr.ml[28,628+0]..[40,898+5])
         pci_virt = Concrete
         pci_params =
           []
-        pci_name = "x" (shortcut_ext_attr.ml[27,612+6]..[27,612+7])
+        pci_name = "x" (shortcut_ext_attr.ml[28,628+6]..[28,628+7])
         pci_expr =
-          class_expr (shortcut_ext_attr.ml[28,622+12]..[39,882+5])
+          class_expr (shortcut_ext_attr.ml[29,638+12]..[40,898+5])
             attribute "foo"
               []
             Pcl_fun
             Nolabel
             None
-            pattern (shortcut_ext_attr.ml[28,622+12]..[28,622+13])
-              Ppat_var "x" (shortcut_ext_attr.ml[28,622+12]..[28,622+13])
-            class_expr (shortcut_ext_attr.ml[29,639+2]..[39,882+5])
+            pattern (shortcut_ext_attr.ml[29,638+12]..[29,638+13])
+              Ppat_var "x" (shortcut_ext_attr.ml[29,638+12]..[29,638+13])
+            class_expr (shortcut_ext_attr.ml[30,655+2]..[40,898+5])
               Pcl_let Nonrec
               [
                 
                     attribute "foo"
                       []
-                  pattern (shortcut_ext_attr.ml[29,639+12]..[29,639+13])
-                    Ppat_var "x" (shortcut_ext_attr.ml[29,639+12]..[29,639+13])
-                  expression (shortcut_ext_attr.ml[29,639+16]..[29,639+17])
+                  pattern (shortcut_ext_attr.ml[30,655+12]..[30,655+13])
+                    Ppat_var "x" (shortcut_ext_attr.ml[30,655+12]..[30,655+13])
+                  expression (shortcut_ext_attr.ml[30,655+16]..[30,655+17])
                     Pexp_constant PConst_int (3,None)
               ]
-              class_expr (shortcut_ext_attr.ml[30,660+2]..[39,882+5])
+              class_expr (shortcut_ext_attr.ml[31,676+2]..[40,898+5])
                 attribute "foo"
                   []
                 Pcl_structure
                 class_structure
-                  pattern (shortcut_ext_attr.ml[30,660+14]..[30,660+14]) ghost
+                  pattern (shortcut_ext_attr.ml[31,676+14]..[31,676+14]) ghost
                     Ppat_any
                   [
-                    class_field (shortcut_ext_attr.ml[31,675+4]..[31,675+19])
+                    class_field (shortcut_ext_attr.ml[32,691+4]..[32,691+19])
                         attribute "foo"
                           []
                       Pcf_inherit Fresh
-                        class_expr (shortcut_ext_attr.ml[31,675+18]..[31,675+19])
-                          Pcl_constr "x" (shortcut_ext_attr.ml[31,675+18]..[31,675+19])
+                        class_expr (shortcut_ext_attr.ml[32,691+18]..[32,691+19])
+                          Pcl_constr "x" (shortcut_ext_attr.ml[32,691+18]..[32,691+19])
                           []
                         None
-                    class_field (shortcut_ext_attr.ml[32,695+4]..[32,695+19])
+                    class_field (shortcut_ext_attr.ml[33,711+4]..[33,711+19])
                         attribute "foo"
                           []
                       Pcf_val Immutable
-                        "x" (shortcut_ext_attr.ml[32,695+14]..[32,695+15])
+                        "x" (shortcut_ext_attr.ml[33,711+14]..[33,711+15])
                         Concrete Fresh
-                        expression (shortcut_ext_attr.ml[32,695+18]..[32,695+19])
+                        expression (shortcut_ext_attr.ml[33,711+18]..[33,711+19])
                           Pexp_constant PConst_int (3,None)
-                    class_field (shortcut_ext_attr.ml[33,715+4]..[33,715+27])
+                    class_field (shortcut_ext_attr.ml[34,731+4]..[34,731+27])
                         attribute "foo"
                           []
                       Pcf_val Immutable
-                        "x" (shortcut_ext_attr.ml[33,715+22]..[33,715+23])
+                        "x" (shortcut_ext_attr.ml[34,731+22]..[34,731+23])
                         Virtual
-                        core_type (shortcut_ext_attr.ml[33,715+26]..[33,715+27])
-                          Ptyp_constr "t" (shortcut_ext_attr.ml[33,715+26]..[33,715+27])
+                        core_type (shortcut_ext_attr.ml[34,731+26]..[34,731+27])
+                          Ptyp_constr "t" (shortcut_ext_attr.ml[34,731+26]..[34,731+27])
                           []
-                    class_field (shortcut_ext_attr.ml[34,743+4]..[34,743+28])
+                    class_field (shortcut_ext_attr.ml[35,759+4]..[35,759+28])
                         attribute "foo"
                           []
                       Pcf_val Mutable
-                        "x" (shortcut_ext_attr.ml[34,743+23]..[34,743+24])
+                        "x" (shortcut_ext_attr.ml[35,759+23]..[35,759+24])
                         Concrete Override
-                        expression (shortcut_ext_attr.ml[34,743+27]..[34,743+28])
+                        expression (shortcut_ext_attr.ml[35,759+27]..[35,759+28])
                           Pexp_constant PConst_int (3,None)
-                    class_field (shortcut_ext_attr.ml[35,772+4]..[35,772+22])
+                    class_field (shortcut_ext_attr.ml[36,788+4]..[36,788+22])
                         attribute "foo"
                           []
                       Pcf_method Public
-                        "x" (shortcut_ext_attr.ml[35,772+17]..[35,772+18])
+                        "x" (shortcut_ext_attr.ml[36,788+17]..[36,788+18])
                         Concrete Fresh
-                        expression (shortcut_ext_attr.ml[35,772+10]..[35,772+22]) ghost
+                        expression (shortcut_ext_attr.ml[36,788+10]..[36,788+22]) ghost
                           Pexp_poly
-                          expression (shortcut_ext_attr.ml[35,772+21]..[35,772+22])
+                          expression (shortcut_ext_attr.ml[36,788+21]..[36,788+22])
                             Pexp_constant PConst_int (3,None)
                           None
-                    class_field (shortcut_ext_attr.ml[36,795+4]..[36,795+30])
+                    class_field (shortcut_ext_attr.ml[37,811+4]..[37,811+30])
                         attribute "foo"
                           []
                       Pcf_method Public
-                        "x" (shortcut_ext_attr.ml[36,795+25]..[36,795+26])
+                        "x" (shortcut_ext_attr.ml[37,811+25]..[37,811+26])
                         Virtual
-                        core_type (shortcut_ext_attr.ml[36,795+29]..[36,795+30])
-                          Ptyp_constr "t" (shortcut_ext_attr.ml[36,795+29]..[36,795+30])
+                        core_type (shortcut_ext_attr.ml[37,811+29]..[37,811+30])
+                          Ptyp_constr "t" (shortcut_ext_attr.ml[37,811+29]..[37,811+30])
                           []
-                    class_field (shortcut_ext_attr.ml[37,826+4]..[37,826+31])
+                    class_field (shortcut_ext_attr.ml[38,842+4]..[38,842+31])
                         attribute "foo"
                           []
                       Pcf_method Private
-                        "x" (shortcut_ext_attr.ml[37,826+26]..[37,826+27])
+                        "x" (shortcut_ext_attr.ml[38,842+26]..[38,842+27])
                         Concrete Override
-                        expression (shortcut_ext_attr.ml[37,826+10]..[37,826+31]) ghost
+                        expression (shortcut_ext_attr.ml[38,842+10]..[38,842+31]) ghost
                           Pexp_poly
-                          expression (shortcut_ext_attr.ml[37,826+30]..[37,826+31])
+                          expression (shortcut_ext_attr.ml[38,842+30]..[38,842+31])
                             Pexp_constant PConst_int (3,None)
                           None
-                    class_field (shortcut_ext_attr.ml[38,858+4]..[38,858+23])
+                    class_field (shortcut_ext_attr.ml[39,874+4]..[39,874+23])
                         attribute "foo"
                           []
                       Pcf_initializer
-                        expression (shortcut_ext_attr.ml[38,858+22]..[38,858+23])
-                          Pexp_ident "x" (shortcut_ext_attr.ml[38,858+22]..[38,858+23])
+                        expression (shortcut_ext_attr.ml[39,874+22]..[39,874+23])
+                          Pexp_ident "x" (shortcut_ext_attr.ml[39,874+22]..[39,874+23])
                   ]
     ]
-  structure_item (shortcut_ext_attr.ml[42,918+0]..[50,1098+5])
+  structure_item (shortcut_ext_attr.ml[43,934+0]..[51,1114+5])
     Pstr_class_type
     [
-      class_type_declaration (shortcut_ext_attr.ml[42,918+0]..[50,1098+5])
+      class_type_declaration (shortcut_ext_attr.ml[43,934+0]..[51,1114+5])
         pci_virt = Concrete
         pci_params =
           []
-        pci_name = "t" (shortcut_ext_attr.ml[42,918+11]..[42,918+12])
+        pci_name = "t" (shortcut_ext_attr.ml[43,934+11]..[43,934+12])
         pci_expr =
-          class_type (shortcut_ext_attr.ml[43,933+2]..[50,1098+5])
+          class_type (shortcut_ext_attr.ml[44,949+2]..[51,1114+5])
             attribute "foo"
               []
             Pcty_signature
             class_signature
-              core_type (shortcut_ext_attr.ml[43,933+14]..[43,933+14])
+              core_type (shortcut_ext_attr.ml[44,949+14]..[44,949+14])
                 Ptyp_any
               [
-                class_type_field (shortcut_ext_attr.ml[44,948+4]..[44,948+19])
+                class_type_field (shortcut_ext_attr.ml[45,964+4]..[45,964+19])
                     attribute "foo"
                       []
                   Pctf_inherit
-                  class_type (shortcut_ext_attr.ml[44,948+18]..[44,948+19])
-                    Pcty_constr "t" (shortcut_ext_attr.ml[44,948+18]..[44,948+19])
+                  class_type (shortcut_ext_attr.ml[45,964+18]..[45,964+19])
+                    Pcty_constr "t" (shortcut_ext_attr.ml[45,964+18]..[45,964+19])
                     []
-                class_type_field (shortcut_ext_attr.ml[45,968+4]..[45,968+19])
+                class_type_field (shortcut_ext_attr.ml[46,984+4]..[46,984+19])
                     attribute "foo"
                       []
                   Pctf_val "x" Immutable Concrete
-                    core_type (shortcut_ext_attr.ml[45,968+18]..[45,968+19])
-                      Ptyp_constr "t" (shortcut_ext_attr.ml[45,968+18]..[45,968+19])
+                    core_type (shortcut_ext_attr.ml[46,984+18]..[46,984+19])
+                      Ptyp_constr "t" (shortcut_ext_attr.ml[46,984+18]..[46,984+19])
                       []
-                class_type_field (shortcut_ext_attr.ml[46,988+4]..[46,988+27])
+                class_type_field (shortcut_ext_attr.ml[47,1004+4]..[47,1004+27])
                     attribute "foo"
                       []
                   Pctf_val "x" Mutable Concrete
-                    core_type (shortcut_ext_attr.ml[46,988+26]..[46,988+27])
-                      Ptyp_constr "t" (shortcut_ext_attr.ml[46,988+26]..[46,988+27])
+                    core_type (shortcut_ext_attr.ml[47,1004+26]..[47,1004+27])
+                      Ptyp_constr "t" (shortcut_ext_attr.ml[47,1004+26]..[47,1004+27])
                       []
-                class_type_field (shortcut_ext_attr.ml[47,1016+4]..[47,1016+22])
+                class_type_field (shortcut_ext_attr.ml[48,1032+4]..[48,1032+22])
                     attribute "foo"
                       []
                   Pctf_method "x" Public Concrete
-                    core_type (shortcut_ext_attr.ml[47,1016+21]..[47,1016+22])
-                      Ptyp_constr "t" (shortcut_ext_attr.ml[47,1016+21]..[47,1016+22])
+                    core_type (shortcut_ext_attr.ml[48,1032+21]..[48,1032+22])
+                      Ptyp_constr "t" (shortcut_ext_attr.ml[48,1032+21]..[48,1032+22])
                       []
-                class_type_field (shortcut_ext_attr.ml[48,1039+4]..[48,1039+30])
+                class_type_field (shortcut_ext_attr.ml[49,1055+4]..[49,1055+30])
                     attribute "foo"
                       []
                   Pctf_method "x" Private Concrete
-                    core_type (shortcut_ext_attr.ml[48,1039+29]..[48,1039+30])
-                      Ptyp_constr "t" (shortcut_ext_attr.ml[48,1039+29]..[48,1039+30])
+                    core_type (shortcut_ext_attr.ml[49,1055+29]..[49,1055+30])
+                      Ptyp_constr "t" (shortcut_ext_attr.ml[49,1055+29]..[49,1055+30])
                       []
-                class_type_field (shortcut_ext_attr.ml[49,1070+4]..[49,1070+27])
+                class_type_field (shortcut_ext_attr.ml[50,1086+4]..[50,1086+27])
                     attribute "foo"
                       []
                   Pctf_constraint
-                    core_type (shortcut_ext_attr.ml[49,1070+21]..[49,1070+22])
-                      Ptyp_constr "t" (shortcut_ext_attr.ml[49,1070+21]..[49,1070+22])
+                    core_type (shortcut_ext_attr.ml[50,1086+21]..[50,1086+22])
+                      Ptyp_constr "t" (shortcut_ext_attr.ml[50,1086+21]..[50,1086+22])
                       []
-                    core_type (shortcut_ext_attr.ml[49,1070+25]..[49,1070+27])
-                      Ptyp_constr "t'" (shortcut_ext_attr.ml[49,1070+25]..[49,1070+27])
+                    core_type (shortcut_ext_attr.ml[50,1086+25]..[50,1086+27])
+                      Ptyp_constr "t'" (shortcut_ext_attr.ml[50,1086+25]..[50,1086+27])
                       []
               ]
     ]
-  structure_item (shortcut_ext_attr.ml[53,1128+0]..[54,1137+22])
+  structure_item (shortcut_ext_attr.ml[54,1144+0]..[55,1153+22])
     Pstr_type Rec
     [
-      type_declaration "t" (shortcut_ext_attr.ml[53,1128+5]..[53,1128+6]) (shortcut_ext_attr.ml[53,1128+0]..[54,1137+22])
+      type_declaration "t" (shortcut_ext_attr.ml[54,1144+5]..[54,1144+6]) (shortcut_ext_attr.ml[54,1144+0]..[55,1153+22])
         ptype_params =
           []
         ptype_cstrs =
@@ -481,86 +497,86 @@
         ptype_private = Public
         ptype_manifest =
           Some
-            core_type (shortcut_ext_attr.ml[54,1137+2]..[54,1137+22]) ghost
+            core_type (shortcut_ext_attr.ml[55,1153+2]..[55,1153+22]) ghost
               Ptyp_extension "foo"
-              core_type (shortcut_ext_attr.ml[54,1137+2]..[54,1137+22])
+              core_type (shortcut_ext_attr.ml[55,1153+2]..[55,1153+22])
                 attribute "foo"
                   []
-                Ptyp_package "M" (shortcut_ext_attr.ml[54,1137+20]..[54,1137+21])
+                Ptyp_package "M" (shortcut_ext_attr.ml[55,1153+20]..[55,1153+21])
                 []
     ]
-  structure_item (shortcut_ext_attr.ml[57,1186+0]..[60,1242+22])
+  structure_item (shortcut_ext_attr.ml[58,1202+0]..[61,1258+22])
     Pstr_module
-    "M" (shortcut_ext_attr.ml[57,1186+7]..[57,1186+8])
-      module_expr (shortcut_ext_attr.ml[58,1197+2]..[60,1242+22])
+    "M" (shortcut_ext_attr.ml[58,1202+7]..[58,1202+8])
+      module_expr (shortcut_ext_attr.ml[59,1213+2]..[61,1258+22])
         attribute "foo"
           []
-        Pmod_functor "M" (shortcut_ext_attr.ml[58,1197+17]..[58,1197+18])
-        module_type (shortcut_ext_attr.ml[58,1197+21]..[58,1197+22])
-          Pmty_ident "S" (shortcut_ext_attr.ml[58,1197+21]..[58,1197+22])
-        module_expr (shortcut_ext_attr.ml[59,1224+4]..[60,1242+22])
+        Pmod_functor "M" (shortcut_ext_attr.ml[59,1213+17]..[59,1213+18])
+        module_type (shortcut_ext_attr.ml[59,1213+21]..[59,1213+22])
+          Pmty_ident "S" (shortcut_ext_attr.ml[59,1213+21]..[59,1213+22])
+        module_expr (shortcut_ext_attr.ml[60,1240+4]..[61,1258+22])
           Pmod_apply
-          module_expr (shortcut_ext_attr.ml[59,1224+4]..[59,1224+17])
+          module_expr (shortcut_ext_attr.ml[60,1240+4]..[60,1240+17])
             attribute "foo"
               []
             Pmod_unpack
-            expression (shortcut_ext_attr.ml[59,1224+15]..[59,1224+16])
-              Pexp_ident "x" (shortcut_ext_attr.ml[59,1224+15]..[59,1224+16])
-          module_expr (shortcut_ext_attr.ml[60,1242+5]..[60,1242+21])
+            expression (shortcut_ext_attr.ml[60,1240+15]..[60,1240+16])
+              Pexp_ident "x" (shortcut_ext_attr.ml[60,1240+15]..[60,1240+16])
+          module_expr (shortcut_ext_attr.ml[61,1258+5]..[61,1258+21])
             attribute "foo"
               []
             Pmod_structure
             []
-  structure_item (shortcut_ext_attr.ml[63,1295+0]..[66,1368+19])
-    Pstr_modtype "S" (shortcut_ext_attr.ml[63,1295+12]..[63,1295+13])
-      module_type (shortcut_ext_attr.ml[64,1311+2]..[66,1368+19])
+  structure_item (shortcut_ext_attr.ml[64,1311+0]..[67,1384+19])
+    Pstr_modtype "S" (shortcut_ext_attr.ml[64,1311+12]..[64,1311+13])
+      module_type (shortcut_ext_attr.ml[65,1327+2]..[67,1384+19])
         attribute "foo"
           []
-        Pmty_functor "M" (shortcut_ext_attr.ml[64,1311+17]..[64,1311+18])
-        module_type (shortcut_ext_attr.ml[64,1311+19]..[64,1311+20])
-          Pmty_ident "S" (shortcut_ext_attr.ml[64,1311+19]..[64,1311+20])
-        module_type (shortcut_ext_attr.ml[65,1336+4]..[66,1368+19])
+        Pmty_functor "M" (shortcut_ext_attr.ml[65,1327+17]..[65,1327+18])
+        module_type (shortcut_ext_attr.ml[65,1327+19]..[65,1327+20])
+          Pmty_ident "S" (shortcut_ext_attr.ml[65,1327+19]..[65,1327+20])
+        module_type (shortcut_ext_attr.ml[66,1352+4]..[67,1384+19])
           Pmty_functor "_" (_none_[1,0+-1]..[1,0+-1]) ghost
-          module_type (shortcut_ext_attr.ml[65,1336+5]..[65,1336+27])
+          module_type (shortcut_ext_attr.ml[66,1352+5]..[66,1352+27])
             attribute "foo"
               []
             Pmty_typeof
-            module_expr (shortcut_ext_attr.ml[65,1336+26]..[65,1336+27])
-              Pmod_ident "M" (shortcut_ext_attr.ml[65,1336+26]..[65,1336+27])
-          module_type (shortcut_ext_attr.ml[66,1368+5]..[66,1368+18])
+            module_expr (shortcut_ext_attr.ml[66,1352+26]..[66,1352+27])
+              Pmod_ident "M" (shortcut_ext_attr.ml[66,1352+26]..[66,1352+27])
+          module_type (shortcut_ext_attr.ml[67,1384+5]..[67,1384+18])
             attribute "foo"
               []
             Pmty_signature
             []
-  structure_item (shortcut_ext_attr.ml[69,1411+0]..[70,1431+15]) ghost
+  structure_item (shortcut_ext_attr.ml[70,1427+0]..[71,1447+15]) ghost
     Pstr_extension "foo"
     [
-      structure_item (shortcut_ext_attr.ml[69,1411+0]..[70,1431+15])
+      structure_item (shortcut_ext_attr.ml[70,1427+0]..[71,1447+15])
         Pstr_value Nonrec
         [
           
               attribute "foo"
                 []
-            pattern (shortcut_ext_attr.ml[69,1411+14]..[69,1411+15])
-              Ppat_var "x" (shortcut_ext_attr.ml[69,1411+14]..[69,1411+15])
-            expression (shortcut_ext_attr.ml[69,1411+18]..[69,1411+19])
+            pattern (shortcut_ext_attr.ml[70,1427+14]..[70,1427+15])
+              Ppat_var "x" (shortcut_ext_attr.ml[70,1427+14]..[70,1427+15])
+            expression (shortcut_ext_attr.ml[70,1427+18]..[70,1427+19])
               Pexp_constant PConst_int (4,None)
           
               attribute "foo"
                 []
-            pattern (shortcut_ext_attr.ml[70,1431+10]..[70,1431+11])
-              Ppat_var "y" (shortcut_ext_attr.ml[70,1431+10]..[70,1431+11])
-            expression (shortcut_ext_attr.ml[70,1431+14]..[70,1431+15])
-              Pexp_ident "x" (shortcut_ext_attr.ml[70,1431+14]..[70,1431+15])
+            pattern (shortcut_ext_attr.ml[71,1447+10]..[71,1447+11])
+              Ppat_var "y" (shortcut_ext_attr.ml[71,1447+10]..[71,1447+11])
+            expression (shortcut_ext_attr.ml[71,1447+14]..[71,1447+15])
+              Pexp_ident "x" (shortcut_ext_attr.ml[71,1447+14]..[71,1447+15])
         ]
     ]
-  structure_item (shortcut_ext_attr.ml[72,1448+0]..[73,1471+17]) ghost
+  structure_item (shortcut_ext_attr.ml[73,1464+0]..[74,1487+17]) ghost
     Pstr_extension "foo"
     [
-      structure_item (shortcut_ext_attr.ml[72,1448+0]..[73,1471+17])
+      structure_item (shortcut_ext_attr.ml[73,1464+0]..[74,1487+17])
         Pstr_type Rec
         [
-          type_declaration "t" (shortcut_ext_attr.ml[72,1448+15]..[72,1448+16]) (shortcut_ext_attr.ml[72,1448+0]..[72,1448+22])
+          type_declaration "t" (shortcut_ext_attr.ml[73,1464+15]..[73,1464+16]) (shortcut_ext_attr.ml[73,1464+0]..[73,1464+22])
             attribute "foo"
               []
             ptype_params =
@@ -572,10 +588,10 @@
             ptype_private = Public
             ptype_manifest =
               Some
-                core_type (shortcut_ext_attr.ml[72,1448+19]..[72,1448+22])
-                  Ptyp_constr "int" (shortcut_ext_attr.ml[72,1448+19]..[72,1448+22])
+                core_type (shortcut_ext_attr.ml[73,1464+19]..[73,1464+22])
+                  Ptyp_constr "int" (shortcut_ext_attr.ml[73,1464+19]..[73,1464+22])
                   []
-          type_declaration "t" (shortcut_ext_attr.ml[73,1471+10]..[73,1471+11]) (shortcut_ext_attr.ml[73,1471+0]..[73,1471+17])
+          type_declaration "t" (shortcut_ext_attr.ml[74,1487+10]..[74,1487+11]) (shortcut_ext_attr.ml[74,1487+0]..[74,1487+17])
             attribute "foo"
               []
             ptype_params =
@@ -587,25 +603,25 @@
             ptype_private = Public
             ptype_manifest =
               Some
-                core_type (shortcut_ext_attr.ml[73,1471+14]..[73,1471+17])
-                  Ptyp_constr "int" (shortcut_ext_attr.ml[73,1471+14]..[73,1471+17])
+                core_type (shortcut_ext_attr.ml[74,1487+14]..[74,1487+17])
+                  Ptyp_constr "int" (shortcut_ext_attr.ml[74,1487+14]..[74,1487+17])
                   []
         ]
     ]
-  structure_item (shortcut_ext_attr.ml[74,1489+0]..[74,1489+21]) ghost
+  structure_item (shortcut_ext_attr.ml[75,1505+0]..[75,1505+21]) ghost
     Pstr_extension "foo"
     [
-      structure_item (shortcut_ext_attr.ml[74,1489+0]..[74,1489+21])
+      structure_item (shortcut_ext_attr.ml[75,1505+0]..[75,1505+21])
         Pstr_typext
         type_extension
           attribute "foo"
             []
-          ptyext_path = "t" (shortcut_ext_attr.ml[74,1489+15]..[74,1489+16])
+          ptyext_path = "t" (shortcut_ext_attr.ml[75,1505+15]..[75,1505+16])
           ptyext_params =
             []
           ptyext_constructors =
             [
-              extension_constructor (shortcut_ext_attr.ml[74,1489+20]..[74,1489+21])
+              extension_constructor (shortcut_ext_attr.ml[75,1505+20]..[75,1505+21])
                 pext_name = "T"
                 pext_kind =
                   Pext_decl
@@ -614,64 +630,64 @@
             ]
           ptyext_private = Public
     ]
-  structure_item (shortcut_ext_attr.ml[76,1512+0]..[76,1512+21]) ghost
+  structure_item (shortcut_ext_attr.ml[77,1528+0]..[77,1528+21]) ghost
     Pstr_extension "foo"
     [
-      structure_item (shortcut_ext_attr.ml[76,1512+0]..[76,1512+21])
+      structure_item (shortcut_ext_attr.ml[77,1528+0]..[77,1528+21])
         Pstr_class
         [
-          class_declaration (shortcut_ext_attr.ml[76,1512+0]..[76,1512+21])
+          class_declaration (shortcut_ext_attr.ml[77,1528+0]..[77,1528+21])
             attribute "foo"
               []
             pci_virt = Concrete
             pci_params =
               []
-            pci_name = "x" (shortcut_ext_attr.ml[76,1512+16]..[76,1512+17])
+            pci_name = "x" (shortcut_ext_attr.ml[77,1528+16]..[77,1528+17])
             pci_expr =
-              class_expr (shortcut_ext_attr.ml[76,1512+20]..[76,1512+21])
-                Pcl_constr "x" (shortcut_ext_attr.ml[76,1512+20]..[76,1512+21])
+              class_expr (shortcut_ext_attr.ml[77,1528+20]..[77,1528+21])
+                Pcl_constr "x" (shortcut_ext_attr.ml[77,1528+20]..[77,1528+21])
                 []
         ]
     ]
-  structure_item (shortcut_ext_attr.ml[77,1534+0]..[77,1534+26]) ghost
+  structure_item (shortcut_ext_attr.ml[78,1550+0]..[78,1550+26]) ghost
     Pstr_extension "foo"
     [
-      structure_item (shortcut_ext_attr.ml[77,1534+0]..[77,1534+26])
+      structure_item (shortcut_ext_attr.ml[78,1550+0]..[78,1550+26])
         Pstr_class_type
         [
-          class_type_declaration (shortcut_ext_attr.ml[77,1534+0]..[77,1534+26])
+          class_type_declaration (shortcut_ext_attr.ml[78,1550+0]..[78,1550+26])
             attribute "foo"
               []
             pci_virt = Concrete
             pci_params =
               []
-            pci_name = "x" (shortcut_ext_attr.ml[77,1534+21]..[77,1534+22])
+            pci_name = "x" (shortcut_ext_attr.ml[78,1550+21]..[78,1550+22])
             pci_expr =
-              class_type (shortcut_ext_attr.ml[77,1534+25]..[77,1534+26])
-                Pcty_constr "x" (shortcut_ext_attr.ml[77,1534+25]..[77,1534+26])
+              class_type (shortcut_ext_attr.ml[78,1550+25]..[78,1550+26])
+                Pcty_constr "x" (shortcut_ext_attr.ml[78,1550+25]..[78,1550+26])
                 []
         ]
     ]
-  structure_item (shortcut_ext_attr.ml[78,1561+0]..[78,1561+30]) ghost
+  structure_item (shortcut_ext_attr.ml[79,1577+0]..[79,1577+30]) ghost
     Pstr_extension "foo"
     [
-      structure_item (shortcut_ext_attr.ml[78,1561+0]..[78,1561+30])
+      structure_item (shortcut_ext_attr.ml[79,1577+0]..[79,1577+30])
         Pstr_primitive
-        value_description "x" (shortcut_ext_attr.ml[78,1561+19]..[78,1561+20]) (shortcut_ext_attr.ml[78,1561+0]..[78,1561+30])
+        value_description "x" (shortcut_ext_attr.ml[79,1577+19]..[79,1577+20]) (shortcut_ext_attr.ml[79,1577+0]..[79,1577+30])
           attribute "foo"
             []
-          core_type (shortcut_ext_attr.ml[78,1561+23]..[78,1561+24])
+          core_type (shortcut_ext_attr.ml[79,1577+23]..[79,1577+24])
             Ptyp_any
           [
             ""
           ]
     ]
-  structure_item (shortcut_ext_attr.ml[79,1592+0]..[79,1592+21]) ghost
+  structure_item (shortcut_ext_attr.ml[80,1608+0]..[80,1608+21]) ghost
     Pstr_extension "foo"
     [
-      structure_item (shortcut_ext_attr.ml[79,1592+0]..[79,1592+21])
+      structure_item (shortcut_ext_attr.ml[80,1608+0]..[80,1608+21])
         Pstr_exception
-        extension_constructor (shortcut_ext_attr.ml[79,1592+0]..[79,1592+21])
+        extension_constructor (shortcut_ext_attr.ml[80,1608+0]..[80,1608+21])
           attribute "foo"
             []
           pext_name = "X"
@@ -680,110 +696,110 @@
               []
               None
     ]
-  structure_item (shortcut_ext_attr.ml[81,1615+0]..[81,1615+22]) ghost
+  structure_item (shortcut_ext_attr.ml[82,1631+0]..[82,1631+22]) ghost
     Pstr_extension "foo"
     [
-      structure_item (shortcut_ext_attr.ml[81,1615+0]..[81,1615+22])
+      structure_item (shortcut_ext_attr.ml[82,1631+0]..[82,1631+22])
         Pstr_module
-        "M" (shortcut_ext_attr.ml[81,1615+17]..[81,1615+18])
+        "M" (shortcut_ext_attr.ml[82,1631+17]..[82,1631+18])
           attribute "foo"
             []
-          module_expr (shortcut_ext_attr.ml[81,1615+21]..[81,1615+22])
-            Pmod_ident "M" (shortcut_ext_attr.ml[81,1615+21]..[81,1615+22])
+          module_expr (shortcut_ext_attr.ml[82,1631+21]..[82,1631+22])
+            Pmod_ident "M" (shortcut_ext_attr.ml[82,1631+21]..[82,1631+22])
     ]
-  structure_item (shortcut_ext_attr.ml[82,1638+0]..[83,1669+19]) ghost
+  structure_item (shortcut_ext_attr.ml[83,1654+0]..[84,1685+19]) ghost
     Pstr_extension "foo"
     [
-      structure_item (shortcut_ext_attr.ml[82,1638+0]..[83,1669+19])
+      structure_item (shortcut_ext_attr.ml[83,1654+0]..[84,1685+19])
         Pstr_recmodule
         [
-          "M" (shortcut_ext_attr.ml[82,1638+21]..[82,1638+22])
+          "M" (shortcut_ext_attr.ml[83,1654+21]..[83,1654+22])
             attribute "foo"
               []
-            module_expr (shortcut_ext_attr.ml[82,1638+23]..[82,1638+30])
+            module_expr (shortcut_ext_attr.ml[83,1654+23]..[83,1654+30])
               Pmod_constraint
-              module_expr (shortcut_ext_attr.ml[82,1638+29]..[82,1638+30])
-                Pmod_ident "M" (shortcut_ext_attr.ml[82,1638+29]..[82,1638+30])
-              module_type (shortcut_ext_attr.ml[82,1638+25]..[82,1638+26])
-                Pmty_ident "S" (shortcut_ext_attr.ml[82,1638+25]..[82,1638+26])
-          "M" (shortcut_ext_attr.ml[83,1669+10]..[83,1669+11])
+              module_expr (shortcut_ext_attr.ml[83,1654+29]..[83,1654+30])
+                Pmod_ident "M" (shortcut_ext_attr.ml[83,1654+29]..[83,1654+30])
+              module_type (shortcut_ext_attr.ml[83,1654+25]..[83,1654+26])
+                Pmty_ident "S" (shortcut_ext_attr.ml[83,1654+25]..[83,1654+26])
+          "M" (shortcut_ext_attr.ml[84,1685+10]..[84,1685+11])
             attribute "foo"
               []
-            module_expr (shortcut_ext_attr.ml[83,1669+12]..[83,1669+19])
+            module_expr (shortcut_ext_attr.ml[84,1685+12]..[84,1685+19])
               Pmod_constraint
-              module_expr (shortcut_ext_attr.ml[83,1669+18]..[83,1669+19])
-                Pmod_ident "M" (shortcut_ext_attr.ml[83,1669+18]..[83,1669+19])
-              module_type (shortcut_ext_attr.ml[83,1669+14]..[83,1669+15])
-                Pmty_ident "S" (shortcut_ext_attr.ml[83,1669+14]..[83,1669+15])
+              module_expr (shortcut_ext_attr.ml[84,1685+18]..[84,1685+19])
+                Pmod_ident "M" (shortcut_ext_attr.ml[84,1685+18]..[84,1685+19])
+              module_type (shortcut_ext_attr.ml[84,1685+14]..[84,1685+15])
+                Pmty_ident "S" (shortcut_ext_attr.ml[84,1685+14]..[84,1685+15])
         ]
     ]
-  structure_item (shortcut_ext_attr.ml[84,1689+0]..[84,1689+27]) ghost
+  structure_item (shortcut_ext_attr.ml[85,1705+0]..[85,1705+27]) ghost
     Pstr_extension "foo"
     [
-      structure_item (shortcut_ext_attr.ml[84,1689+0]..[84,1689+27])
-        Pstr_modtype "S" (shortcut_ext_attr.ml[84,1689+22]..[84,1689+23])
+      structure_item (shortcut_ext_attr.ml[85,1705+0]..[85,1705+27])
+        Pstr_modtype "S" (shortcut_ext_attr.ml[85,1705+22]..[85,1705+23])
           attribute "foo"
             []
-          module_type (shortcut_ext_attr.ml[84,1689+26]..[84,1689+27])
-            Pmty_ident "S" (shortcut_ext_attr.ml[84,1689+26]..[84,1689+27])
+          module_type (shortcut_ext_attr.ml[85,1705+26]..[85,1705+27])
+            Pmty_ident "S" (shortcut_ext_attr.ml[85,1705+26]..[85,1705+27])
     ]
-  structure_item (shortcut_ext_attr.ml[86,1718+0]..[86,1718+19]) ghost
+  structure_item (shortcut_ext_attr.ml[87,1734+0]..[87,1734+19]) ghost
     Pstr_extension "foo"
     [
-      structure_item (shortcut_ext_attr.ml[86,1718+0]..[86,1718+19])
+      structure_item (shortcut_ext_attr.ml[87,1734+0]..[87,1734+19])
         Pstr_include          attribute "foo"
             []
-        module_expr (shortcut_ext_attr.ml[86,1718+18]..[86,1718+19])
-          Pmod_ident "M" (shortcut_ext_attr.ml[86,1718+18]..[86,1718+19])
+        module_expr (shortcut_ext_attr.ml[87,1734+18]..[87,1734+19])
+          Pmod_ident "M" (shortcut_ext_attr.ml[87,1734+18]..[87,1734+19])
     ]
-  structure_item (shortcut_ext_attr.ml[87,1738+0]..[87,1738+16]) ghost
+  structure_item (shortcut_ext_attr.ml[88,1754+0]..[88,1754+16]) ghost
     Pstr_extension "foo"
     [
-      structure_item (shortcut_ext_attr.ml[87,1738+0]..[87,1738+16])
-        Pstr_open Fresh "M" (shortcut_ext_attr.ml[87,1738+15]..[87,1738+16])
+      structure_item (shortcut_ext_attr.ml[88,1754+0]..[88,1754+16])
+        Pstr_open Fresh "M" (shortcut_ext_attr.ml[88,1754+15]..[88,1754+16])
           attribute "foo"
             []
     ]
-  structure_item (shortcut_ext_attr.ml[90,1778+0]..[113,2174+3])
-    Pstr_modtype "S" (shortcut_ext_attr.ml[90,1778+12]..[90,1778+13])
-      module_type (shortcut_ext_attr.ml[90,1778+16]..[113,2174+3])
+  structure_item (shortcut_ext_attr.ml[91,1794+0]..[114,2190+3])
+    Pstr_modtype "S" (shortcut_ext_attr.ml[91,1794+12]..[91,1794+13])
+      module_type (shortcut_ext_attr.ml[91,1794+16]..[114,2190+3])
         Pmty_signature
         [
-          signature_item (shortcut_ext_attr.ml[91,1798+2]..[91,1798+21]) ghost
+          signature_item (shortcut_ext_attr.ml[92,1814+2]..[92,1814+21]) ghost
             Psig_extension "foo"
             [
-              signature_item (shortcut_ext_attr.ml[91,1798+2]..[91,1798+21])
+              signature_item (shortcut_ext_attr.ml[92,1814+2]..[92,1814+21])
                 Psig_value
-                value_description "x" (shortcut_ext_attr.ml[91,1798+16]..[91,1798+17]) (shortcut_ext_attr.ml[91,1798+2]..[91,1798+21])
+                value_description "x" (shortcut_ext_attr.ml[92,1814+16]..[92,1814+17]) (shortcut_ext_attr.ml[92,1814+2]..[92,1814+21])
                   attribute "foo"
                     []
-                  core_type (shortcut_ext_attr.ml[91,1798+20]..[91,1798+21])
-                    Ptyp_constr "t" (shortcut_ext_attr.ml[91,1798+20]..[91,1798+21])
+                  core_type (shortcut_ext_attr.ml[92,1814+20]..[92,1814+21])
+                    Ptyp_constr "t" (shortcut_ext_attr.ml[92,1814+20]..[92,1814+21])
                     []
                   []
             ]
-          signature_item (shortcut_ext_attr.ml[92,1820+2]..[92,1820+31]) ghost
+          signature_item (shortcut_ext_attr.ml[93,1836+2]..[93,1836+31]) ghost
             Psig_extension "foo"
             [
-              signature_item (shortcut_ext_attr.ml[92,1820+2]..[92,1820+31])
+              signature_item (shortcut_ext_attr.ml[93,1836+2]..[93,1836+31])
                 Psig_value
-                value_description "x" (shortcut_ext_attr.ml[92,1820+21]..[92,1820+22]) (shortcut_ext_attr.ml[92,1820+2]..[92,1820+31])
+                value_description "x" (shortcut_ext_attr.ml[93,1836+21]..[93,1836+22]) (shortcut_ext_attr.ml[93,1836+2]..[93,1836+31])
                   attribute "foo"
                     []
-                  core_type (shortcut_ext_attr.ml[92,1820+25]..[92,1820+26])
-                    Ptyp_constr "t" (shortcut_ext_attr.ml[92,1820+25]..[92,1820+26])
+                  core_type (shortcut_ext_attr.ml[93,1836+25]..[93,1836+26])
+                    Ptyp_constr "t" (shortcut_ext_attr.ml[93,1836+25]..[93,1836+26])
                     []
                   [
                     ""
                   ]
             ]
-          signature_item (shortcut_ext_attr.ml[94,1853+2]..[95,1878+20]) ghost
+          signature_item (shortcut_ext_attr.ml[95,1869+2]..[96,1894+20]) ghost
             Psig_extension "foo"
             [
-              signature_item (shortcut_ext_attr.ml[94,1853+2]..[95,1878+20])
+              signature_item (shortcut_ext_attr.ml[95,1869+2]..[96,1894+20])
                 Psig_type Rec
                 [
-                  type_declaration "t" (shortcut_ext_attr.ml[94,1853+17]..[94,1853+18]) (shortcut_ext_attr.ml[94,1853+2]..[94,1853+24])
+                  type_declaration "t" (shortcut_ext_attr.ml[95,1869+17]..[95,1869+18]) (shortcut_ext_attr.ml[95,1869+2]..[95,1869+24])
                     attribute "foo"
                       []
                     ptype_params =
@@ -795,10 +811,10 @@
                     ptype_private = Public
                     ptype_manifest =
                       Some
-                        core_type (shortcut_ext_attr.ml[94,1853+21]..[94,1853+24])
-                          Ptyp_constr "int" (shortcut_ext_attr.ml[94,1853+21]..[94,1853+24])
+                        core_type (shortcut_ext_attr.ml[95,1869+21]..[95,1869+24])
+                          Ptyp_constr "int" (shortcut_ext_attr.ml[95,1869+21]..[95,1869+24])
                           []
-                  type_declaration "t'" (shortcut_ext_attr.ml[95,1878+12]..[95,1878+14]) (shortcut_ext_attr.ml[95,1878+2]..[95,1878+20])
+                  type_declaration "t'" (shortcut_ext_attr.ml[96,1894+12]..[96,1894+14]) (shortcut_ext_attr.ml[96,1894+2]..[96,1894+20])
                     attribute "foo"
                       []
                     ptype_params =
@@ -810,25 +826,25 @@
                     ptype_private = Public
                     ptype_manifest =
                       Some
-                        core_type (shortcut_ext_attr.ml[95,1878+17]..[95,1878+20])
-                          Ptyp_constr "int" (shortcut_ext_attr.ml[95,1878+17]..[95,1878+20])
+                        core_type (shortcut_ext_attr.ml[96,1894+17]..[96,1894+20])
+                          Ptyp_constr "int" (shortcut_ext_attr.ml[96,1894+17]..[96,1894+20])
                           []
                 ]
             ]
-          signature_item (shortcut_ext_attr.ml[96,1899+2]..[96,1899+23]) ghost
+          signature_item (shortcut_ext_attr.ml[97,1915+2]..[97,1915+23]) ghost
             Psig_extension "foo"
             [
-              signature_item (shortcut_ext_attr.ml[96,1899+2]..[96,1899+23])
+              signature_item (shortcut_ext_attr.ml[97,1915+2]..[97,1915+23])
                 Psig_typext
                 type_extension
                   attribute "foo"
                     []
-                  ptyext_path = "t" (shortcut_ext_attr.ml[96,1899+17]..[96,1899+18])
+                  ptyext_path = "t" (shortcut_ext_attr.ml[97,1915+17]..[97,1915+18])
                   ptyext_params =
                     []
                   ptyext_constructors =
                     [
-                      extension_constructor (shortcut_ext_attr.ml[96,1899+22]..[96,1899+23])
+                      extension_constructor (shortcut_ext_attr.ml[97,1915+22]..[97,1915+23])
                         pext_name = "T"
                         pext_kind =
                           Pext_decl
@@ -837,12 +853,12 @@
                     ]
                   ptyext_private = Public
             ]
-          signature_item (shortcut_ext_attr.ml[98,1924+2]..[98,1924+23]) ghost
+          signature_item (shortcut_ext_attr.ml[99,1940+2]..[99,1940+23]) ghost
             Psig_extension "foo"
             [
-              signature_item (shortcut_ext_attr.ml[98,1924+2]..[98,1924+23])
+              signature_item (shortcut_ext_attr.ml[99,1940+2]..[99,1940+23])
                 Psig_exception
-                extension_constructor (shortcut_ext_attr.ml[98,1924+2]..[98,1924+23])
+                extension_constructor (shortcut_ext_attr.ml[99,1940+2]..[99,1940+23])
                   attribute "foo"
                     []
                   pext_name = "X"
@@ -851,107 +867,107 @@
                       []
                       None
             ]
-          signature_item (shortcut_ext_attr.ml[100,1949+2]..[100,1949+24]) ghost
+          signature_item (shortcut_ext_attr.ml[101,1965+2]..[101,1965+24]) ghost
             Psig_extension "foo"
             [
-              signature_item (shortcut_ext_attr.ml[100,1949+2]..[100,1949+24])
-                Psig_module "M" (shortcut_ext_attr.ml[100,1949+19]..[100,1949+20])
+              signature_item (shortcut_ext_attr.ml[101,1965+2]..[101,1965+24])
+                Psig_module "M" (shortcut_ext_attr.ml[101,1965+19]..[101,1965+20])
                   attribute "foo"
                     []
-                module_type (shortcut_ext_attr.ml[100,1949+23]..[100,1949+24])
-                  Pmty_ident "S" (shortcut_ext_attr.ml[100,1949+23]..[100,1949+24])
+                module_type (shortcut_ext_attr.ml[101,1965+23]..[101,1965+24])
+                  Pmty_ident "S" (shortcut_ext_attr.ml[101,1965+23]..[101,1965+24])
             ]
-          signature_item (shortcut_ext_attr.ml[101,1974+2]..[102,2003+17]) ghost
+          signature_item (shortcut_ext_attr.ml[102,1990+2]..[103,2019+17]) ghost
             Psig_extension "foo"
             [
-              signature_item (shortcut_ext_attr.ml[101,1974+2]..[102,2003+17])
+              signature_item (shortcut_ext_attr.ml[102,1990+2]..[103,2019+17])
                 Psig_recmodule
                 [
-                  "M" (shortcut_ext_attr.ml[101,1974+23]..[101,1974+24])
+                  "M" (shortcut_ext_attr.ml[102,1990+23]..[102,1990+24])
                     attribute "foo"
                       []
-                    module_type (shortcut_ext_attr.ml[101,1974+27]..[101,1974+28])
-                      Pmty_ident "S" (shortcut_ext_attr.ml[101,1974+27]..[101,1974+28])
-                  "M" (shortcut_ext_attr.ml[102,2003+12]..[102,2003+13])
+                    module_type (shortcut_ext_attr.ml[102,1990+27]..[102,1990+28])
+                      Pmty_ident "S" (shortcut_ext_attr.ml[102,1990+27]..[102,1990+28])
+                  "M" (shortcut_ext_attr.ml[103,2019+12]..[103,2019+13])
                     attribute "foo"
                       []
-                    module_type (shortcut_ext_attr.ml[102,2003+16]..[102,2003+17])
-                      Pmty_ident "S" (shortcut_ext_attr.ml[102,2003+16]..[102,2003+17])
+                    module_type (shortcut_ext_attr.ml[103,2019+16]..[103,2019+17])
+                      Pmty_ident "S" (shortcut_ext_attr.ml[103,2019+16]..[103,2019+17])
                 ]
             ]
-          signature_item (shortcut_ext_attr.ml[103,2021+2]..[103,2021+24]) ghost
+          signature_item (shortcut_ext_attr.ml[104,2037+2]..[104,2037+24]) ghost
             Psig_extension "foo"
             [
-              signature_item (shortcut_ext_attr.ml[103,2021+2]..[103,2021+24])
-                Psig_module "M" (shortcut_ext_attr.ml[103,2021+19]..[103,2021+20])
+              signature_item (shortcut_ext_attr.ml[104,2037+2]..[104,2037+24])
+                Psig_module "M" (shortcut_ext_attr.ml[104,2037+19]..[104,2037+20])
                   attribute "foo"
                     []
-                module_type (shortcut_ext_attr.ml[103,2021+23]..[103,2021+24])
-                  Pmty_alias "M" (shortcut_ext_attr.ml[103,2021+23]..[103,2021+24])
+                module_type (shortcut_ext_attr.ml[104,2037+23]..[104,2037+24])
+                  Pmty_alias "M" (shortcut_ext_attr.ml[104,2037+23]..[104,2037+24])
             ]
-          signature_item (shortcut_ext_attr.ml[105,2047+2]..[105,2047+29]) ghost
+          signature_item (shortcut_ext_attr.ml[106,2063+2]..[106,2063+29]) ghost
             Psig_extension "foo"
             [
-              signature_item (shortcut_ext_attr.ml[105,2047+2]..[105,2047+29])
-                Psig_modtype "S" (shortcut_ext_attr.ml[105,2047+24]..[105,2047+25])
+              signature_item (shortcut_ext_attr.ml[106,2063+2]..[106,2063+29])
+                Psig_modtype "S" (shortcut_ext_attr.ml[106,2063+24]..[106,2063+25])
                   attribute "foo"
                     []
-                  module_type (shortcut_ext_attr.ml[105,2047+28]..[105,2047+29])
-                    Pmty_ident "S" (shortcut_ext_attr.ml[105,2047+28]..[105,2047+29])
+                  module_type (shortcut_ext_attr.ml[106,2063+28]..[106,2063+29])
+                    Pmty_ident "S" (shortcut_ext_attr.ml[106,2063+28]..[106,2063+29])
             ]
-          signature_item (shortcut_ext_attr.ml[107,2078+2]..[107,2078+21]) ghost
+          signature_item (shortcut_ext_attr.ml[108,2094+2]..[108,2094+21]) ghost
             Psig_extension "foo"
             [
-              signature_item (shortcut_ext_attr.ml[107,2078+2]..[107,2078+21])
+              signature_item (shortcut_ext_attr.ml[108,2094+2]..[108,2094+21])
                 Psig_include
-                module_type (shortcut_ext_attr.ml[107,2078+20]..[107,2078+21])
-                  Pmty_ident "M" (shortcut_ext_attr.ml[107,2078+20]..[107,2078+21])
+                module_type (shortcut_ext_attr.ml[108,2094+20]..[108,2094+21])
+                  Pmty_ident "M" (shortcut_ext_attr.ml[108,2094+20]..[108,2094+21])
                   attribute "foo"
                     []
             ]
-          signature_item (shortcut_ext_attr.ml[108,2100+2]..[108,2100+18]) ghost
+          signature_item (shortcut_ext_attr.ml[109,2116+2]..[109,2116+18]) ghost
             Psig_extension "foo"
             [
-              signature_item (shortcut_ext_attr.ml[108,2100+2]..[108,2100+18])
-                Psig_open Fresh "M" (shortcut_ext_attr.ml[108,2100+17]..[108,2100+18])
+              signature_item (shortcut_ext_attr.ml[109,2116+2]..[109,2116+18])
+                Psig_open Fresh "M" (shortcut_ext_attr.ml[109,2116+17]..[109,2116+18])
                   attribute "foo"
                     []
             ]
-          signature_item (shortcut_ext_attr.ml[110,2120+2]..[110,2120+23]) ghost
+          signature_item (shortcut_ext_attr.ml[111,2136+2]..[111,2136+23]) ghost
             Psig_extension "foo"
             [
-              signature_item (shortcut_ext_attr.ml[110,2120+2]..[110,2120+23])
+              signature_item (shortcut_ext_attr.ml[111,2136+2]..[111,2136+23])
                 Psig_class
                 [
-                  class_description (shortcut_ext_attr.ml[110,2120+2]..[110,2120+23])
+                  class_description (shortcut_ext_attr.ml[111,2136+2]..[111,2136+23])
                     attribute "foo"
                       []
                     pci_virt = Concrete
                     pci_params =
                       []
-                    pci_name = "x" (shortcut_ext_attr.ml[110,2120+18]..[110,2120+19])
+                    pci_name = "x" (shortcut_ext_attr.ml[111,2136+18]..[111,2136+19])
                     pci_expr =
-                      class_type (shortcut_ext_attr.ml[110,2120+22]..[110,2120+23])
-                        Pcty_constr "t" (shortcut_ext_attr.ml[110,2120+22]..[110,2120+23])
+                      class_type (shortcut_ext_attr.ml[111,2136+22]..[111,2136+23])
+                        Pcty_constr "t" (shortcut_ext_attr.ml[111,2136+22]..[111,2136+23])
                         []
                 ]
             ]
-          signature_item (shortcut_ext_attr.ml[111,2144+2]..[111,2144+28]) ghost
+          signature_item (shortcut_ext_attr.ml[112,2160+2]..[112,2160+28]) ghost
             Psig_extension "foo"
             [
-              signature_item (shortcut_ext_attr.ml[111,2144+2]..[111,2144+28])
+              signature_item (shortcut_ext_attr.ml[112,2160+2]..[112,2160+28])
                 Psig_class_type
                 [
-                  class_type_declaration (shortcut_ext_attr.ml[111,2144+2]..[111,2144+28])
+                  class_type_declaration (shortcut_ext_attr.ml[112,2160+2]..[112,2160+28])
                     attribute "foo"
                       []
                     pci_virt = Concrete
                     pci_params =
                       []
-                    pci_name = "x" (shortcut_ext_attr.ml[111,2144+23]..[111,2144+24])
+                    pci_name = "x" (shortcut_ext_attr.ml[112,2160+23]..[112,2160+24])
                     pci_expr =
-                      class_type (shortcut_ext_attr.ml[111,2144+27]..[111,2144+28])
-                        Pcty_constr "x" (shortcut_ext_attr.ml[111,2144+27]..[111,2144+28])
+                      class_type (shortcut_ext_attr.ml[112,2160+27]..[112,2160+28])
+                        Pcty_constr "x" (shortcut_ext_attr.ml[112,2160+27]..[112,2160+28])
                         []
                 ]
             ]
@@ -959,4 +975,4 @@
 ]
 
 File "shortcut_ext_attr.ml", line 4, characters 6-9:
-Uninterpreted extension 'foo'.
+Error: Uninterpreted extension 'foo'.
diff --git a/testsuite/tests/prim-bswap/bswap.ml b/testsuite/tests/prim-bswap/bswap.ml
index 40ab21ff..9d757335 100644
--- a/testsuite/tests/prim-bswap/bswap.ml
+++ b/testsuite/tests/prim-bswap/bswap.ml
@@ -1,16 +1,3 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                                OCaml                                *)
-(*                                                                     *)
-(*                   Benedikt Meurer, os-cillation GmbH                *)
-(*                                                                     *)
-(*    Copyright 1998 Institut National de Recherche en Informatique    *)
-(*    et en Automatique. Copyright 2013 Benedikt Meurer. All rights    *)
-(*    reserved.  This file is distributed  under the terms of the Q    *)
-(*    Public License version 1.0.                                      *)
-(*                                                                     *)
-(***********************************************************************)
-
 open Printf
 
 external bswap16: int -> int = "%bswap16"
diff --git a/testsuite/tests/prim-revapply/apply.ml b/testsuite/tests/prim-revapply/apply.ml
index ad17edea..1a169e18 100644
--- a/testsuite/tests/prim-revapply/apply.ml
+++ b/testsuite/tests/prim-revapply/apply.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                   Fabrice Le Fessant, INRIA Saclay                     *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 external ( @@ ) :  ('a -> 'b) -> 'a -> 'b = "%apply"
 
 let f x = x + x
diff --git a/testsuite/tests/prim-revapply/revapply.ml b/testsuite/tests/prim-revapply/revapply.ml
index c8055004..f8b0dc2e 100644
--- a/testsuite/tests/prim-revapply/revapply.ml
+++ b/testsuite/tests/prim-revapply/revapply.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                   Fabrice Le Fessant, INRIA Saclay                     *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
 
 let f x = x + x
diff --git a/testsuite/tests/regression/pr3612/pr3612.ml b/testsuite/tests/regression/pr3612/pr3612.ml
index 6ae495f8..70f42740 100644
--- a/testsuite/tests/regression/pr3612/pr3612.ml
+++ b/testsuite/tests/regression/pr3612/pr3612.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                        Pierre Chambart, OCamlPro                       *)
-(*                                                                        *)
-(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 type t
 
 external test_alloc : unit -> t = "caml_test_pr3612_alloc"
diff --git a/testsuite/tests/regression/pr5080-notes/pr5080_notes_ok.ml b/testsuite/tests/regression/pr5080-notes/pr5080_notes_ok.ml
index 6bde667c..175bc8b7 100644
--- a/testsuite/tests/regression/pr5080-notes/pr5080_notes_ok.ml
+++ b/testsuite/tests/regression/pr5080-notes/pr5080_notes_ok.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Damien Doligez, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2011 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let marshal_int f  =
   match [] with
   | _ :: `INT n :: _ -> f n
diff --git a/testsuite/tests/regression/pr5233/pr5233.ml b/testsuite/tests/regression/pr5233/pr5233.ml
index 15d3dd9e..b7fddd7f 100644
--- a/testsuite/tests/regression/pr5233/pr5233.ml
+++ b/testsuite/tests/regression/pr5233/pr5233.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Damien Doligez, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Printf;;
 
 (* PR#5233: Create a dangling pointer and use it to access random parts
diff --git a/testsuite/tests/regression/pr5757/pr5757.ml b/testsuite/tests/regression/pr5757/pr5757.ml
index ddc4b693..4bd8d85f 100644
--- a/testsuite/tests/regression/pr5757/pr5757.ml
+++ b/testsuite/tests/regression/pr5757/pr5757.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Damien Doligez, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 Random.init 3;;
 for i = 0 to 100_000 do
   ignore (Bytes.create (Random.int 1_000_000))
diff --git a/testsuite/tests/regression/pr6024/pr6024.ml b/testsuite/tests/regression/pr6024/pr6024.ml
index 0134f3bd..7798a5ff 100644
--- a/testsuite/tests/regression/pr6024/pr6024.ml
+++ b/testsuite/tests/regression/pr6024/pr6024.ml
@@ -1,16 +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 GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 Format.printf "@[%@-@@-@]@.";;
diff --git a/testsuite/tests/regression/pr7042/pr7042.ml b/testsuite/tests/regression/pr7042/pr7042.ml
index eeb7ea91..3fa80abe 100644
--- a/testsuite/tests/regression/pr7042/pr7042.ml
+++ b/testsuite/tests/regression/pr7042/pr7042.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Xavier Leroy, projet Gallium, INRIA Paris-Rocquencourt       *)
-(*                                                                        *)
-(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let _ =
   let a = [| 0.0; -. 0.0 |] in
   Printf.printf "%Lx %Lx\n"
diff --git a/testsuite/tests/runtime-errors/stackoverflow.ml b/testsuite/tests/runtime-errors/stackoverflow.ml
index c32fb9a8..ab53b8b0 100644
--- a/testsuite/tests/runtime-errors/stackoverflow.ml
+++ b/testsuite/tests/runtime-errors/stackoverflow.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2001 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let rec f x =
   if not (x = 0 || x = 10000 || x = 20000)
   then 1 + f (x + 1)
diff --git a/testsuite/tests/runtime-errors/syserror.ml b/testsuite/tests/runtime-errors/syserror.ml
index 7a318fb7..46f62ead 100644
--- a/testsuite/tests/runtime-errors/syserror.ml
+++ b/testsuite/tests/runtime-errors/syserror.ml
@@ -1,16 +1 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let channel = open_out "titi:/toto"
diff --git a/testsuite/tests/self-contained-toplevel/Makefile b/testsuite/tests/self-contained-toplevel/Makefile
new file mode 100644
index 00000000..5126305b
--- /dev/null
+++ b/testsuite/tests/self-contained-toplevel/Makefile
@@ -0,0 +1,34 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                  Jeremie Dimino, Jane Street Europe                    *
+#*                                                                        *
+#*   Copyright 2016 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed 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=../..
+LIBRARIES=ocaml
+MODULES=foo cached_cmi
+MAIN_MODULE=main
+COMPFLAGS=-I $(OTOPDIR)/typing -I $(OTOPDIR)/toplevel
+LIBRARIES=../../../compilerlibs/ocamlcommon \
+          ../../../compilerlibs/ocamlbytecomp \
+          ../../../compilerlibs/ocamltoplevel
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
+
+BYTECODE_ONLY=true
+GENERATED_SOURCES+=cached_cmi.ml
+EXEC_ARGS=$(OCFLAGS) -noinit input.ml
+
+cached_cmi.ml: foo.cmi gen_cached_cmi.ml
+	@$(OCAML) ../../../compilerlibs/ocamlcommon.cma -I $(OTOPDIR)/typing \
+	          gen_cached_cmi.ml > $@
diff --git a/testsuite/tests/self-contained-toplevel/foo.ml b/testsuite/tests/self-contained-toplevel/foo.ml
new file mode 100644
index 00000000..2747ada0
--- /dev/null
+++ b/testsuite/tests/self-contained-toplevel/foo.ml
@@ -0,0 +1 @@
+let value = "Hello, world!"
diff --git a/testsuite/tests/self-contained-toplevel/gen_cached_cmi.ml b/testsuite/tests/self-contained-toplevel/gen_cached_cmi.ml
new file mode 100644
index 00000000..176c3b2e
--- /dev/null
+++ b/testsuite/tests/self-contained-toplevel/gen_cached_cmi.ml
@@ -0,0 +1,4 @@
+let () =
+  let cmi = Cmi_format.read_cmi "foo.cmi" in
+  let data = Marshal.to_string cmi [] in
+  Printf.printf "let foo = %S\n" data
diff --git a/testsuite/tests/self-contained-toplevel/input.ml b/testsuite/tests/self-contained-toplevel/input.ml
new file mode 100644
index 00000000..46072371
--- /dev/null
+++ b/testsuite/tests/self-contained-toplevel/input.ml
@@ -0,0 +1 @@
+print_endline Foo.value;;
diff --git a/testsuite/tests/self-contained-toplevel/main.ml b/testsuite/tests/self-contained-toplevel/main.ml
new file mode 100644
index 00000000..606c4df5
--- /dev/null
+++ b/testsuite/tests/self-contained-toplevel/main.ml
@@ -0,0 +1,13 @@
+let () =
+  (* Make sure it's no longer available on disk *)
+  if Sys.file_exists "foo.cmi" then Sys.remove "foo.cmi";
+  let old_loader = !Env.Persistent_signature.load in
+  Env.Persistent_signature.load := (fun ~unit_name ->
+    match unit_name with
+    | "Foo" ->
+      Some { Env.Persistent_signature.
+             filename = Sys.executable_name
+           ; cmi      = Marshal.from_string Cached_cmi.foo 0
+           }
+    | _ -> old_loader unit_name);
+  Topmain.main ()
diff --git a/testsuite/tests/self-contained-toplevel/main.reference b/testsuite/tests/self-contained-toplevel/main.reference
new file mode 100644
index 00000000..af5626b4
--- /dev/null
+++ b/testsuite/tests/self-contained-toplevel/main.reference
@@ -0,0 +1 @@
+Hello, world!
diff --git a/testsuite/tests/tool-lexyacc/gram_aux.ml b/testsuite/tests/tool-lexyacc/gram_aux.ml
index be964b04..019565f8 100644
--- a/testsuite/tests/tool-lexyacc/gram_aux.ml
+++ b/testsuite/tests/tool-lexyacc/gram_aux.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Auxiliaries for the parser. *)
 
 open Syntax
diff --git a/testsuite/tests/tool-lexyacc/grammar.mly b/testsuite/tests/tool-lexyacc/grammar.mly
index 26f9ce51..02a7155e 100644
--- a/testsuite/tests/tool-lexyacc/grammar.mly
+++ b/testsuite/tests/tool-lexyacc/grammar.mly
@@ -1,18 +1,3 @@
-/**************************************************************************/
-/*                                                                        */
-/*                                OCaml                                   */
-/*                                                                        */
-/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
-/*                                                                        */
-/*   Copyright 1996 Institut National de Recherche en Informatique et     */
-/*     en Automatique.                                                    */
-/*                                                                        */
-/*   All rights reserved.  This file is distributed under the terms of    */
-/*   the GNU Lesser General Public License version 2.1, with the          */
-/*   special exception on linking described in the file LICENSE.          */
-/*                                                                        */
-/**************************************************************************/
-
 /* The grammar for lexer definitions */
 
 %{
diff --git a/testsuite/tests/tool-lexyacc/lexgen.ml b/testsuite/tests/tool-lexyacc/lexgen.ml
index 6c158456..ff34fe01 100644
--- a/testsuite/tests/tool-lexyacc/lexgen.ml
+++ b/testsuite/tests/tool-lexyacc/lexgen.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Compiling a lexer definition *)
 
 open Syntax
diff --git a/testsuite/tests/tool-lexyacc/main.ml b/testsuite/tests/tool-lexyacc/main.ml
index 89ee9a1a..16b9a3a9 100644
--- a/testsuite/tests/tool-lexyacc/main.ml
+++ b/testsuite/tests/tool-lexyacc/main.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* The lexer generator. Command-line parsing. *)
 
 open Syntax
diff --git a/testsuite/tests/tool-lexyacc/output.ml b/testsuite/tests/tool-lexyacc/output.ml
index f8bbb16c..973aa5e4 100644
--- a/testsuite/tests/tool-lexyacc/output.ml
+++ b/testsuite/tests/tool-lexyacc/output.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Generating a DFA as a set of mutually recursive functions *)
 
 open Syntax
@@ -22,14 +7,14 @@ let oc = ref stdout
 
 (* 1- Generating the actions *)
 
-let copy_buffer = String.create 1024
+let copy_buffer = Bytes.create 1024
 
 let copy_chunk (Location(start,stop)) =
   seek_in !ic start;
   let tocopy = ref(stop - start) in
   while !tocopy > 0 do
     let m =
-      input !ic copy_buffer 0 (min !tocopy (String.length copy_buffer)) in
+      input !ic copy_buffer 0 (min !tocopy (Bytes.length copy_buffer)) in
     output !oc copy_buffer 0 m;
     tocopy := !tocopy - m
   done
diff --git a/testsuite/tests/tool-lexyacc/scan_aux.ml b/testsuite/tests/tool-lexyacc/scan_aux.ml
index 9f378d52..96362fce 100644
--- a/testsuite/tests/tool-lexyacc/scan_aux.ml
+++ b/testsuite/tests/tool-lexyacc/scan_aux.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Auxiliaries for the lexical analyzer *)
 
 let brace_depth = ref 0
@@ -20,7 +5,7 @@ let comment_depth = ref 0
 
 exception Lexical_error of string
 
-let initial_string_buffer = String.create 256
+let initial_string_buffer = Bytes.create 256
 let string_buff = ref initial_string_buffer
 let string_index = ref 0
 
@@ -31,17 +16,17 @@ let reset_string_buffer () =
 
 let store_string_char c =
   begin
-    if !string_index >= String.length !string_buff then begin
-      let new_buff = String.create (String.length !string_buff * 2) in
-      String.blit new_buff 0 !string_buff 0 (String.length !string_buff);
+    if !string_index >= Bytes.length !string_buff then begin
+      let new_buff = Bytes.create (Bytes.length !string_buff * 2) in
+      Bytes.blit new_buff 0 !string_buff 0 (Bytes.length !string_buff);
       string_buff := new_buff
     end
   end;
-  String.unsafe_set !string_buff !string_index c;
+  Bytes.unsafe_set !string_buff !string_index c;
   incr string_index
 
 let get_stored_string () =
-  let s = String.sub !string_buff 0 !string_index in
+  let s = Bytes.sub_string !string_buff 0 !string_index in
   string_buff := initial_string_buffer;
   s
 
diff --git a/testsuite/tests/tool-lexyacc/scanner.mll b/testsuite/tests/tool-lexyacc/scanner.mll
index 8e07215a..f21fd7cd 100644
--- a/testsuite/tests/tool-lexyacc/scanner.mll
+++ b/testsuite/tests/tool-lexyacc/scanner.mll
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* The lexical analyzer for lexer definitions. *)
 
 {
diff --git a/testsuite/tests/tool-lexyacc/syntax.ml b/testsuite/tests/tool-lexyacc/syntax.ml
index ece0584e..f692e6f6 100644
--- a/testsuite/tests/tool-lexyacc/syntax.ml
+++ b/testsuite/tests/tool-lexyacc/syntax.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* The shallow abstract syntax *)
 
 type location =
diff --git a/testsuite/tests/tool-ocaml/t121-setstringchar.ml b/testsuite/tests/tool-ocaml/t121-setstringchar.ml
index 939ed973..ea19572e 100644
--- a/testsuite/tests/tool-ocaml/t121-setstringchar.ml
+++ b/testsuite/tests/tool-ocaml/t121-setstringchar.ml
@@ -1,7 +1,7 @@
 open Lib;;
-let x = "foo" in
+let x = Bytes.of_string "foo" in
 x.[2] <- 'x';
-if x.[2] <> 'x' then raise Not_found
+if Bytes.get x 2 <> 'x' then raise Not_found
 ;;
 
 (**
diff --git a/testsuite/tests/tool-ocaml/t240-c_call4.ml b/testsuite/tests/tool-ocaml/t240-c_call4.ml
index 7b66ab14..8297eb14 100644
--- a/testsuite/tests/tool-ocaml/t240-c_call4.ml
+++ b/testsuite/tests/tool-ocaml/t240-c_call4.ml
@@ -1,7 +1,7 @@
 open Lib;;
-let s = "abcdefgh" in
-String.unsafe_fill s 0 6 'x';
-if s.[5] <> 'x' then raise Not_found
+let s = Bytes.of_string "abcdefgh" in
+Bytes.unsafe_fill s 0 6 'x';
+if Bytes.get s 5 <> 'x' then raise Not_found
 ;;
 
 (**
diff --git a/testsuite/tests/tool-ocaml/t240-c_call5.ml b/testsuite/tests/tool-ocaml/t240-c_call5.ml
index 4c6c92d1..535bb377 100644
--- a/testsuite/tests/tool-ocaml/t240-c_call5.ml
+++ b/testsuite/tests/tool-ocaml/t240-c_call5.ml
@@ -1,7 +1,7 @@
 open Lib;;
-let s = "abcdefgh" in
-String.unsafe_blit s 3 s 0 3;
-if s.[0] <> 'd' then raise Not_found
+let s = Bytes.of_string "abcdefgh" in
+Bytes.unsafe_blit s 3 s 0 3;
+if Bytes.get s 0 <> 'd' then raise Not_found
 ;;
 
 (**
diff --git a/testsuite/tests/tool-ocamldoc-2/Makefile b/testsuite/tests/tool-ocamldoc-2/Makefile
index 372041d5..ff155cf1 100644
--- a/testsuite/tests/tool-ocamldoc-2/Makefile
+++ b/testsuite/tests/tool-ocamldoc-2/Makefile
@@ -33,10 +33,11 @@ default:
 	fi
 
 .PHONY: run
-run: *.mli
-	@for file in *.mli; do \
+run: *.ml *.mli
+	@for file in *.mli *.ml; do \
 	  printf " ... testing '$$file'"; \
 	  F="`basename $$file .mli`"; \
+	  F="`basename $$F .ml`"; \
 	  $(OCAMLDOC) $(DOCFLAGS) -hide-warnings -latex $ \
 	              -o $$F.result $$file; \
 	  $(DIFF) $$F.reference $$F.result >/dev/null \
diff --git a/testsuite/tests/tool-ocamldoc-2/extensible_variant.ml b/testsuite/tests/tool-ocamldoc-2/extensible_variant.ml
new file mode 100644
index 00000000..01c67af4
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-2/extensible_variant.ml
@@ -0,0 +1,20 @@
+(** Testing display of extensible variant types.
+
+   @test_types_display
+ *)
+
+type e = ..
+
+module M = struct
+  type e +=
+  | A (** A doc *)
+  | B (** B doc *)
+  | C (** C doc *)
+end
+
+module type MT = sig
+  type e +=
+  | A (** A doc *)
+  | B (** B doc *)
+  | C (** C doc *)
+end
diff --git a/testsuite/tests/tool-ocamldoc-2/extensible_variant.reference b/testsuite/tests/tool-ocamldoc-2/extensible_variant.reference
new file mode 100644
index 00000000..85962002
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-2/extensible_variant.reference
@@ -0,0 +1,108 @@
+\documentclass[11pt]{article} 
+\usepackage[latin1]{inputenc} 
+\usepackage[T1]{fontenc} 
+\usepackage{textcomp}
+\usepackage{fullpage} 
+\usepackage{url} 
+\usepackage{ocamldoc}
+\begin{document}
+\tableofcontents
+\section{Module {\tt{Extensible\_variant}} : Testing display of extensible variant types.}
+\label{Extensible-underscorevariant}\index{Extensible-underscorevariant@\verb`Extensible_variant`}
+
+
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\label{TYPExtensible-underscorevariant.e}\begin{ocamldoccode}
+type e = ..
+\end{ocamldoccode}
+\index{e@\verb`e`}
+
+
+
+
+\begin{ocamldoccode}
+{\tt{module }}{\tt{M}}{\tt{ : }}\end{ocamldoccode}
+\label{Extensible-underscorevariant.M}\index{M@\verb`M`}
+
+\begin{ocamldocsigend}
+
+
+\begin{ocamldoccode}
+type e +=
+\end{ocamldoccode}
+\label{extension:Extensible-underscorevariant.M.A}\begin{ocamldoccode}
+  | A
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+A doc
+
+
+\end{ocamldoccomment}
+\label{extension:Extensible-underscorevariant.M.B}\begin{ocamldoccode}
+  | B
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+B doc
+
+
+\end{ocamldoccomment}
+\label{extension:Extensible-underscorevariant.M.C}\begin{ocamldoccode}
+  | C
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+C doc
+
+
+\end{ocamldoccomment}
+\end{ocamldocsigend}
+
+
+
+
+
+
+\begin{ocamldoccode}
+{\tt{module type }}{\tt{MT}}{\tt{ = }}\end{ocamldoccode}
+\label{Extensible-underscorevariant.MT}\index{MT@\verb`MT`}
+
+\begin{ocamldocsigend}
+
+
+\begin{ocamldoccode}
+type e +=
+\end{ocamldoccode}
+\label{extension:Extensible-underscorevariant.MT.A}\begin{ocamldoccode}
+  | A
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+A doc
+
+
+\end{ocamldoccomment}
+\label{extension:Extensible-underscorevariant.MT.B}\begin{ocamldoccode}
+  | B
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+B doc
+
+
+\end{ocamldoccomment}
+\label{extension:Extensible-underscorevariant.MT.C}\begin{ocamldoccode}
+  | C
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+C doc
+
+
+\end{ocamldoccomment}
+\end{ocamldocsigend}
+
+
+
+
+\end{document}
\ No newline at end of file
diff --git a/testsuite/tests/tool-ocamldoc-2/inline_records.mli b/testsuite/tests/tool-ocamldoc-2/inline_records.mli
new file mode 100644
index 00000000..ee5f14d7
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-2/inline_records.mli
@@ -0,0 +1,48 @@
+(**
+  This test focuses on the printing of documentation for inline record
+  within the latex generator.
+*)
+
+
+(** A nice exception *)
+exception Simple
+
+(** A less simple exception *)
+exception Less of int
+
+(** An open sum type *)
+type ext = ..
+
+(** A simple record type for reference *)
+type r = { lbl: int (** Field documentation for non-inline, [lbl : int] *);
+          more:int list (** More documentation for r, [more : int list] *) }
+
+
+(** A sum type with one inline record *)
+type t = A of {lbl: int (** [A] field documentation *)
+              ; more:int list (** More [A] field documentation *) }
+(** Constructor documentation *)
+
+(** A sum type with two inline records *)
+type s =
+  | B of { a_label_for_B : int (** [B] field documentation *);
+               more_label_for_B:int list (** More [B] field documentation *) }
+  (** Constructor B documentation *)
+  | C of { c_has_label_too: float (** [C] field documentation*);
+           more_than_one: unit (** ... documentations *)  }
+  (** Constructor C documentation *)
+
+(** A gadt constructor *)
+type any = D: { any:'a (** [A] field [any:'a] for [D] in [any]. *) } -> any
+(** Constructor D documentation *)
+
+exception Error of {name:string (** Error field documentation [name:string] *) }
+
+type ext +=
+  | E of { yet_another_field: unit (** Field documentation for [E] in ext *) }
+  (** Constructor E documentation *)
+  | F of { even_more: int -> int (** Some field documentations for [F] *) }
+  (** Constructor F documentation *)
+  | G of { last: int -> int (** The last and least field documentation *) }
+  (** Constructor G documentation *)
+(** Two new constructors for ext *)
diff --git a/testsuite/tests/tool-ocamldoc-2/inline_records.reference b/testsuite/tests/tool-ocamldoc-2/inline_records.reference
new file mode 100644
index 00000000..84cfb9af
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-2/inline_records.reference
@@ -0,0 +1,292 @@
+\documentclass[11pt]{article} 
+\usepackage[latin1]{inputenc} 
+\usepackage[T1]{fontenc} 
+\usepackage{textcomp}
+\usepackage{fullpage} 
+\usepackage{url} 
+\usepackage{ocamldoc}
+\begin{document}
+\tableofcontents
+\section{Module {\tt{Inline\_records}} : This test focuses on the printing of documentation for inline record
+  within the latex generator.}
+\label{Inline-underscorerecords}\index{Inline-underscorerecords@\verb`Inline_records`}
+
+
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\begin{ocamldoccode}
+exception Simple
+\end{ocamldoccode}
+\index{Simple@\verb`Simple`}
+\begin{ocamldocdescription}
+A nice exception
+
+
+\end{ocamldocdescription}
+
+
+
+
+\begin{ocamldoccode}
+exception Less of int
+
+\end{ocamldoccode}
+\index{Less@\verb`Less`}
+\begin{ocamldocdescription}
+A less simple exception
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords.ext}\begin{ocamldoccode}
+type ext = ..
+\end{ocamldoccode}
+\index{ext@\verb`ext`}
+\begin{ocamldocdescription}
+An open sum type
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords.r}\begin{ocamldoccode}
+type r = 
+{\char123}  lbl : int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Field documentation for non-inline, {\tt{lbl : int}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  more : int list ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+More documentation for r, {\tt{more : int list}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\index{r@\verb`r`}
+\begin{ocamldocdescription}
+A simple record type for reference
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords.t}\begin{ocamldoccode}
+type t =
+  | A of {\char123}  lbl : int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{A}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  more : int list ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+More {\tt{A}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor documentation
+
+
+\end{ocamldoccomment}
+\index{t@\verb`t`}
+\begin{ocamldocdescription}
+A sum type with one inline record
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords.s}\begin{ocamldoccode}
+type s =
+  | B of {\char123}  a_label_for_B : int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{B}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  more_label_for_B : int list ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+More {\tt{B}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor B documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  | C of {\char123}  c_has_label_too : float ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{C}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  more_than_one : unit ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+$\ldots$ documentations
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor C documentation
+
+
+\end{ocamldoccomment}
+\index{s@\verb`s`}
+\begin{ocamldocdescription}
+A sum type with two inline records
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords.any}\begin{ocamldoccode}
+type any =
+  | D : {\char123}  any : {\textquotesingle}a ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{A}} field {\tt{any:{\textquotesingle}a}} for {\tt{D}} in {\tt{any}}.
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+ ->
+any
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor D documentation
+
+
+\end{ocamldoccomment}
+\index{any@\verb`any`}
+\begin{ocamldocdescription}
+A gadt constructor
+
+
+\end{ocamldocdescription}
+
+
+
+
+\begin{ocamldoccode}
+exception Error of {\char123}  name : string ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Error field documentation {\tt{name:string}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+
+\end{ocamldoccode}
+\index{Error@\verb`Error`}
+
+
+
+
+\begin{ocamldoccode}
+type ext +=
+\end{ocamldoccode}
+\label{extension:Inline-underscorerecords.E}\begin{ocamldoccode}
+  | E of {\char123}  yet_another_field : unit ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Field documentation for {\tt{E}} in ext
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor E documentation
+
+
+\end{ocamldoccomment}
+\label{extension:Inline-underscorerecords.F}\begin{ocamldoccode}
+  | F of {\char123}  even_more : int -> int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Some field documentations for {\tt{F}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor F documentation
+
+
+\end{ocamldoccomment}
+\label{extension:Inline-underscorerecords.G}\begin{ocamldoccode}
+  | G of {\char123}  last : int -> int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+The last and least field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor G documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldocdescription}
+Two new constructors for ext
+
+
+\end{ocamldocdescription}
+
+
+\end{document}
\ No newline at end of file
diff --git a/testsuite/tests/tool-ocamldoc-2/inline_records_bis.ml b/testsuite/tests/tool-ocamldoc-2/inline_records_bis.ml
new file mode 100644
index 00000000..ee5f14d7
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-2/inline_records_bis.ml
@@ -0,0 +1,48 @@
+(**
+  This test focuses on the printing of documentation for inline record
+  within the latex generator.
+*)
+
+
+(** A nice exception *)
+exception Simple
+
+(** A less simple exception *)
+exception Less of int
+
+(** An open sum type *)
+type ext = ..
+
+(** A simple record type for reference *)
+type r = { lbl: int (** Field documentation for non-inline, [lbl : int] *);
+          more:int list (** More documentation for r, [more : int list] *) }
+
+
+(** A sum type with one inline record *)
+type t = A of {lbl: int (** [A] field documentation *)
+              ; more:int list (** More [A] field documentation *) }
+(** Constructor documentation *)
+
+(** A sum type with two inline records *)
+type s =
+  | B of { a_label_for_B : int (** [B] field documentation *);
+               more_label_for_B:int list (** More [B] field documentation *) }
+  (** Constructor B documentation *)
+  | C of { c_has_label_too: float (** [C] field documentation*);
+           more_than_one: unit (** ... documentations *)  }
+  (** Constructor C documentation *)
+
+(** A gadt constructor *)
+type any = D: { any:'a (** [A] field [any:'a] for [D] in [any]. *) } -> any
+(** Constructor D documentation *)
+
+exception Error of {name:string (** Error field documentation [name:string] *) }
+
+type ext +=
+  | E of { yet_another_field: unit (** Field documentation for [E] in ext *) }
+  (** Constructor E documentation *)
+  | F of { even_more: int -> int (** Some field documentations for [F] *) }
+  (** Constructor F documentation *)
+  | G of { last: int -> int (** The last and least field documentation *) }
+  (** Constructor G documentation *)
+(** Two new constructors for ext *)
diff --git a/testsuite/tests/tool-ocamldoc-2/inline_records_bis.reference b/testsuite/tests/tool-ocamldoc-2/inline_records_bis.reference
new file mode 100644
index 00000000..6524f488
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-2/inline_records_bis.reference
@@ -0,0 +1,291 @@
+\documentclass[11pt]{article} 
+\usepackage[latin1]{inputenc} 
+\usepackage[T1]{fontenc} 
+\usepackage{textcomp}
+\usepackage{fullpage} 
+\usepackage{url} 
+\usepackage{ocamldoc}
+\begin{document}
+\tableofcontents
+\section{Module {\tt{Inline\_records\_bis}} : This test focuses on the printing of documentation for inline record
+  within the latex generator.}
+\label{Inline-underscorerecords-underscorebis}\index{Inline-underscorerecords-underscorebis@\verb`Inline_records_bis`}
+
+
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\begin{ocamldoccode}
+exception Simple
+\end{ocamldoccode}
+\index{Simple@\verb`Simple`}
+\begin{ocamldocdescription}
+A nice exception
+
+
+\end{ocamldocdescription}
+
+
+
+
+\begin{ocamldoccode}
+exception Less of int
+
+\end{ocamldoccode}
+\index{Less@\verb`Less`}
+\begin{ocamldocdescription}
+A less simple exception
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords-underscorebis.ext}\begin{ocamldoccode}
+type ext = ..
+\end{ocamldoccode}
+\index{ext@\verb`ext`}
+\begin{ocamldocdescription}
+An open sum type
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords-underscorebis.r}\begin{ocamldoccode}
+type r = 
+{\char123}  lbl : int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Field documentation for non-inline, {\tt{lbl : int}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  more : int list ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+More documentation for r, {\tt{more : int list}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\index{r@\verb`r`}
+\begin{ocamldocdescription}
+A simple record type for reference
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords-underscorebis.t}\begin{ocamldoccode}
+type t =
+  | A of {\char123}  lbl : int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{A}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  more : int list ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+More {\tt{A}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor documentation
+
+
+\end{ocamldoccomment}
+\index{t@\verb`t`}
+\begin{ocamldocdescription}
+A sum type with one inline record
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords-underscorebis.s}\begin{ocamldoccode}
+type s =
+  | B of {\char123}  a_label_for_B : int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{B}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  more_label_for_B : int list ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+More {\tt{B}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor B documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  | C of {\char123}  c_has_label_too : float ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{C}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  more_than_one : unit ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+$\ldots$ documentations
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor C documentation
+
+
+\end{ocamldoccomment}
+\index{s@\verb`s`}
+\begin{ocamldocdescription}
+A sum type with two inline records
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords-underscorebis.any}\begin{ocamldoccode}
+type any =
+  | D : {\char123}  any : {\textquotesingle}a ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{A}} field {\tt{any:{\textquotesingle}a}} for {\tt{D}} in {\tt{any}}.
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+ ->
+any
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor D documentation
+
+
+\end{ocamldoccomment}
+\index{any@\verb`any`}
+\begin{ocamldocdescription}
+A gadt constructor
+
+
+\end{ocamldocdescription}
+
+
+
+
+\begin{ocamldoccode}
+exception Error of {\char123}  name : string ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Error field documentation {\tt{name:string}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+
+\end{ocamldoccode}
+\index{Error@\verb`Error`}
+
+
+
+
+\begin{ocamldoccode}
+type ext +=
+\end{ocamldoccode}
+\label{extension:Inline-underscorerecords-underscorebis.E}\begin{ocamldoccode}
+  | E of {\char123}  yet_another_field : unit ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Field documentation for {\tt{E}} in ext
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor E documentation
+
+
+\end{ocamldoccomment}
+\label{extension:Inline-underscorerecords-underscorebis.F}\begin{ocamldoccode}
+  | F of {\char123}  even_more : int -> int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Some field documentations for {\tt{F}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor F documentation
+
+
+\end{ocamldoccomment}
+\label{extension:Inline-underscorerecords-underscorebis.G}\begin{ocamldoccode}
+  | G of {\char123}  last : int -> int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+The last and least field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor G documentation
+
+
+\end{ocamldoccomment}
+
+
+
+
+Two new constructors for ext
+
+\end{document}
\ No newline at end of file
diff --git a/testsuite/tests/tool-ocamldoc-html/Inline_records.mli b/testsuite/tests/tool-ocamldoc-html/Inline_records.mli
new file mode 100644
index 00000000..f80cd2bd
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/Inline_records.mli
@@ -0,0 +1,45 @@
+(**
+  This test focuses on the printing of documentation for inline record
+  within the latex generator.
+*)
+
+
+(** A nice exception *)
+exception Simple
+
+(** An open sum type *)
+type ext = ..
+
+(** A simple record type for reference *)
+type r = { lbl: int (** Field documentation for non-inline, [lbl : int] *);
+          more:int list (** More documentation for r, [more : int list] *) }
+
+
+(** A sum type with one inline record *)
+type t = A of {lbl: int (** [A] field documentation *)
+              ; more:int list (** More [A] field documentation *) }
+(** Constructor documentation *)
+
+(** A sum type with two inline records *)
+type s =
+  | B of { a_label_for_B : int (** [B] field documentation *);
+               more_label_for_B:int list (** More [B] field documentation *) }
+  (** Constructor B documentation *)
+  | C of { c_has_label_too: float (** [C] field documentation*);
+           more_than_one: unit (** ... documentations *)  }
+  (** Constructor C documentation *)
+
+(** A gadt constructor *)
+type any = D: { any:'a (** [A] field [any:'a] for [D] in [any]. *) } -> any
+(** Constructor D documentation *)
+
+exception Error of {name:string (** Error field documentation [name:string] *) }
+
+type ext +=
+  | E of { yet_another_field: unit (** Field documentation for [E] in ext *) }
+  (** Constructor E documentation *)
+  | F of { even_more: int -> int (** Some field documentations for [F] *) }
+  (** Constructor F documentation *)
+  | G of { last: int -> int (** The last and least field documentation *) }
+  (** Constructor G documentation *)
+(** Two new constructors for ext *)
diff --git a/testsuite/tests/tool-ocamldoc-html/Inline_records.reference b/testsuite/tests/tool-ocamldoc-html/Inline_records.reference
new file mode 100644
index 00000000..856c902f
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/Inline_records.reference
@@ -0,0 +1,289 @@
+
+
+
+
+
+
+
+
+
+
+
+
+Inline_records
+
+
+
 Up
+ 

+
Module Inline_records

+
+
module Inline_records: sig .. end

+This test focuses on the printing of documentation for inline record
+  within the latex generator.

+

+

+
+
exception Simple

+

+A nice exception

+

+
+
type ext = ..

+

+An open sum type

+

+
+
+
type r = {

+
+
+
+
+
+
+
+
+
+

+  
+lbl : int;(*

+Field documentation for non-inline, lbl : int

+

+		*)

+  
+more : int list;(*

+More documentation for r, more : int list

+

+		*)

+}
+
+

+A simple record type for reference

+

+
+
+
type t = 

+
+
+
+
+

+|
+A of {
+
+
+
+
+
+
+
+
+
+

+  
+lbl : int;(*

+A field documentation

+

+		*)

+  
+more : int list;(*

+More A field documentation

+

+		*)

+}
+		(*

+Constructor documentation

+

+		*)

+
+

+A sum type with one inline record

+

+
+
+
type s = 

+
+
+
+
+
+
+
+
+
+

+|
+B of {
+
+
+
+
+
+
+
+
+
+

+  
+a_label_for_B : int;(*

+B field documentation

+

+		*)

+  
+more_label_for_B : int list;(*

+More B field documentation

+

+		*)

+}
+		(*

+Constructor B documentation

+

+		*)

+|
+C of {
+
+
+
+
+
+
+
+
+
+

+  
+c_has_label_too : float;(*

+C field documentation

+

+		*)

+  
+more_than_one : unit;(*

+... documentations

+

+		*)

+}
+		(*

+Constructor C documentation

+

+		*)

+
+

+A sum type with two inline records

+

+
+
+
type any = 

+
+
+
+
+

+|
+D : {
+
+
+
+
+

+  
+any : 'a;(*

+A field any:'a for D in any.

+

+		*)

+}
+ -> any		(*

+Constructor D documentation

+

+		*)

+
+

+A gadt constructor

+

+
+
+
exception Error of {
+
+
+
+
+

+  
+name : string;(*

+Error field documentation name:string

+

+		*)

+}
+

+
type ext += 

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

+|
+E of {
+
+
+
+
+

+  
+yet_another_field : unit;(*

+Field documentation for E in ext

+

+		*)

+}
+		(*

+Constructor E documentation

+

+		*)

+|
+F of {
+
+
+
+
+

+  
+even_more : int -> int;(*

+Some field documentations for F

+

+		*)

+}
+		(*

+Constructor F documentation

+

+		*)

+|
+G of {
+
+
+
+
+

+  
+last : int -> int;(*

+The last and least field documentation

+

+		*)

+}
+		(*

+Constructor G documentation

+

+		*)

+
+

+Two new constructors for ext

+

+
+
\ No newline at end of file
diff --git a/testsuite/tests/tool-ocamldoc-html/Linebreaks.mli b/testsuite/tests/tool-ocamldoc-html/Linebreaks.mli
new file mode 100644
index 00000000..764e7f4a
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/Linebreaks.mli
@@ -0,0 +1,69 @@
+(**
+   This file tests the encoding of linebreak inside OCaml code by the
+   ocamldoc html backend.
+
+   Two slightly different aspects are tested in this very file.
+
+   - First, inside a "pre" tags, blanks character should not be escaped.
+   For instance, the generated html code for this test fragment should not
+   contain any 
 tag:
+   {[
+     let f x =
+       let g x =
+         let h x = x in
+         h x in
+       g x
+   ]}
+   See {{:http://caml.inria.fr/mantis/view.php?id=6341} MPR#6341} for more
+   details or the file Linebreaks.html generated by ocamldoc from this file.
+
+   -Second, outside of a "pre"  tags, blank characters in embedded code
+   should be escaped, in order to make them render in a "pre"-like fashion.
+   A good example should be the files type_{i Modulename}.html generated by
+   ocamldoc that should contains the signature of the module [Modulename] in
+   a "code" tags.
+   For instance with the following type definitions,
+*)
+
+type a = A
+type 'a b = {field:'a}
+type c = C: 'a -> c
+
+type s = ..
+type s += B
+
+val x : a
+
+module S: sig module I:sig end end
+module type s = sig end
+
+class type d = object end
+
+exception E of {inline:int}
+
+
+(** type_Linebreaks.html should contain
+
+{[
+sig
+  type a = A
+  type 'a b = { field : 'a; }
+  type c = C : 'a -> Linebreaks.c
+  type s = ..
+  type s += B
+  val x : Linebreaks.a
+  module S : sig module I : sig  end end
+  module type s = sig  end
+  class type d = object  end
+  exception E of { inline : int; }
+end
+]}
+
+with 
 tags used for linebreaks.
+Another example would be [ let f x =
+x] which is rendered with a 
 linebreak inside Linebreaks.html.
+
+See {{:http://caml.inria.fr/mantis/view.php?id=7272}MPR#7272} for more
+information.
+
+*)
diff --git a/testsuite/tests/tool-ocamldoc-html/Linebreaks.reference b/testsuite/tests/tool-ocamldoc-html/Linebreaks.reference
new file mode 100644
index 00000000..71a020fb
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/Linebreaks.reference
@@ -0,0 +1,140 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Linebreaks
+
+
+
 Up
+ 

+
Module Linebreaks

+
+
module Linebreaks: sig .. end

+This file tests the encoding of linebreak inside OCaml code by the
+   ocamldoc html backend.
+

+
+   Two slightly different aspects are tested in this very file.
+

+
    
+
  • First, inside a "pre" tags, blanks character should not be escaped.
+   For instance, the generated html code for this test fragment should not
+   contain any <br> tag:
+   
         let f x =
+       let g x =
+         let h x = x in
+         h x in
+       g x
+   
    
+   See  MPR#6341 for more
+   details or the file Linebreaks.html generated by ocamldoc from this file.
    • 
+

+
+   -Second, outside of a "pre"  tags, blank characters in embedded code
+   should be escaped, in order to make them render in a "pre"-like fashion.
+   A good example should be the files type_Modulename.html generated by
+   ocamldoc that should contains the signature of the module Modulename in
+   a "code" tags.
+   For instance with the following type definitions,

+

+

+
+
type a = 

+
+
+
+
+

+|
+A

+
+
+
+
type 'a b = {

+
+
+
+
+

+  
+field : 'a;

+}
+
+
+
+
type c = 

+
+
+
+
+

+|
+C : 'a -> c

+
+
+
+
type s = ..

+
+
type s += 

+
+
+
+
+

+|
+B

+
+
+
+
val x : a

+
module S: sig .. end

+
module type s = sig .. end

+
class type d = object .. end

+
exception E of {
+
+
+
+
+

+  
+inline : int;

+}
+

+

+type_Linebreaks.html should contain
+

+
+
sig
+  type a = A
+  type 'a b = { field : 'a; }
+  type c = C : 'a -> Linebreaks.c
+  type s = ..
+  type s += B
+  val x : Linebreaks.a
+  module S : sig module I : sig  end end
+  module type s = sig  end
+  class type d = object  end
+  exception E of { inline : int; }
+end
+

+

+
+with <br> tags used for linebreaks.
+Another example would be  let f x =

+x which is rendered with a <br> linebreak inside Linebreaks.html.
+

+
+See MPR#7272 for more
+information.

+
\ No newline at end of file
diff --git a/testsuite/tests/tool-ocamldoc-html/Makefile b/testsuite/tests/tool-ocamldoc-html/Makefile
new file mode 100644
index 00000000..c9160b4a
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/Makefile
@@ -0,0 +1,60 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+COMPFLAGS=-I $(OTOPDIR)/ocamldoc
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/str
+DOCFLAGS=-I $(OTOPDIR)/stdlib $(COMPFLAGS)\
+	-latextitle "6,subsection*" \
+	-latextitle "7,subsubsection*" \
+	-latex-type-prefix "TYP" \
+	-latex-module-prefix "" \
+	-latex-module-type-prefix "" \
+	-latex-value-prefix ""
+
+.PHONY: default
+default:
+	@if ! $(SUPPORTS_SHARED_LIBRARIES); then \
+	  echo 'skipped (shared libraries not available)'; \
+	else \
+	  $(SET_LD_PATH) $(MAKE) run; \
+	fi
+
+.PHONY: run
+run: *.mli
+	@for file in *.mli; do \
+	  printf " ... testing '$$file'"; \
+	  F="`basename $$file .mli`"; \
+	  $(OCAMLDOC) $(DOCFLAGS) -colorize-code -hide-warnings -html $ \
+	              -o index $$file; \
+	  cp $$F.html $$F.result; \
+	  $(DIFF) $$F.reference $$F.result >/dev/null \
+	  && echo " => passed" || echo " => failed"; \
+	done;\
+# For linebreaks.mli, we also compare type_Linebreaks.html and not only
+# themain html file
+	@cp type_Linebreaks.html type_Linebreaks.result;\
+	printf " ... testing 'type_Linebreak.html'";\
+	$(DIFF) type_Linebreaks.reference type_Linebreaks.result\
+	&& echo " => passed" || echo " => failed"
+
+.PHONY: promote
+promote: defaultpromote
+
+.PHONY: clean
+clean: defaultclean
+	@rm -f *.result *.html *.tex *.log *.out *.sty *.toc *.css *.aux
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/tool-ocamldoc-html/type_Linebreaks.reference b/testsuite/tests/tool-ocamldoc-html/type_Linebreaks.reference
new file mode 100644
index 00000000..ad097f11
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/type_Linebreaks.reference
@@ -0,0 +1,27 @@
+
+
+
+
+
+
+
+
+
+
+
+
+Linebreaks
+
+
+sig

+  type a = A

+  type 'a b = { field : 'a; }

+  type c = C : 'a -> Linebreaks.c

+  type s = ..

+  type s += B

+  val x : Linebreaks.a

+  module S : sig module I : sig  end end

+  module type s = sig  end

+  class type d = object  end

+  exception E of { inline : int; }

+end
\ No newline at end of file
diff --git a/testsuite/tests/tool-ocamldoc-man/Inline_records.mli b/testsuite/tests/tool-ocamldoc-man/Inline_records.mli
new file mode 100644
index 00000000..f80cd2bd
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-man/Inline_records.mli
@@ -0,0 +1,45 @@
+(**
+  This test focuses on the printing of documentation for inline record
+  within the latex generator.
+*)
+
+
+(** A nice exception *)
+exception Simple
+
+(** An open sum type *)
+type ext = ..
+
+(** A simple record type for reference *)
+type r = { lbl: int (** Field documentation for non-inline, [lbl : int] *);
+          more:int list (** More documentation for r, [more : int list] *) }
+
+
+(** A sum type with one inline record *)
+type t = A of {lbl: int (** [A] field documentation *)
+              ; more:int list (** More [A] field documentation *) }
+(** Constructor documentation *)
+
+(** A sum type with two inline records *)
+type s =
+  | B of { a_label_for_B : int (** [B] field documentation *);
+               more_label_for_B:int list (** More [B] field documentation *) }
+  (** Constructor B documentation *)
+  | C of { c_has_label_too: float (** [C] field documentation*);
+           more_than_one: unit (** ... documentations *)  }
+  (** Constructor C documentation *)
+
+(** A gadt constructor *)
+type any = D: { any:'a (** [A] field [any:'a] for [D] in [any]. *) } -> any
+(** Constructor D documentation *)
+
+exception Error of {name:string (** Error field documentation [name:string] *) }
+
+type ext +=
+  | E of { yet_another_field: unit (** Field documentation for [E] in ext *) }
+  (** Constructor E documentation *)
+  | F of { even_more: int -> int (** Some field documentations for [F] *) }
+  (** Constructor F documentation *)
+  | G of { last: int -> int (** The last and least field documentation *) }
+  (** Constructor G documentation *)
+(** Two new constructors for ext *)
diff --git a/testsuite/tests/tool-ocamldoc-man/Inline_records.reference b/testsuite/tests/tool-ocamldoc-man/Inline_records.reference
new file mode 100644
index 00000000..7184b971
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-man/Inline_records.reference
@@ -0,0 +1,201 @@
+.SH NAME
+Inline_records \- This test focuses on the printing of documentation for inline record within the latex generator.
+.SH Module
+Module   Inline_records
+.SH Documentation
+.sp
+Module
+.BI "Inline_records"
+ : 
+.B sig  end
+
+.sp
+This test focuses on the printing of documentation for inline record
+within the latex generator\&.
+
+.sp
+
+.sp
+.sp
+
+.I exception Simple 
+
+.sp
+A nice exception
+
+.sp
+.I type ext 
+= ..
+
+.sp
+An open sum type
+
+.sp
+.I type r 
+= {
+ lbl : 
+.B int
+;  (* Field documentation for non\-inline, 
+.B lbl : int
+
+ *) 
+ more : 
+.B int list
+;  (* More documentation for r, 
+.B more : int list
+
+ *) 
+ }
+
+.sp
+A simple record type for reference
+
+.sp
+.I type t 
+=
+ | A
+.B of {
+ lbl : 
+.B int
+;  (* 
+.B A
+field documentation
+ *) 
+ more : 
+.B int list
+;  (* More 
+.B A
+field documentation
+ *) 
+ }
+.I "  "
+  (* Constructor documentation
+ *)
+ 
+.sp
+A sum type with one inline record
+
+.sp
+.I type s 
+=
+ | B
+.B of {
+ a_label_for_B : 
+.B int
+;  (* 
+.B B
+field documentation
+ *) 
+ more_label_for_B : 
+.B int list
+;  (* More 
+.B B
+field documentation
+ *) 
+ }
+.I "  "
+  (* Constructor B documentation
+ *)
+ | C
+.B of {
+ c_has_label_too : 
+.B float
+;  (* 
+.B C
+field documentation
+ *) 
+ more_than_one : 
+.B unit
+;  (* \&.\&.\&. documentations
+ *) 
+ }
+.I "  "
+  (* Constructor C documentation
+ *)
+ 
+.sp
+A sum type with two inline records
+
+.sp
+.I type any 
+=
+ | D
+.B of {
+ any : 
+.B 'a
+;  (* 
+.B A
+field 
+.B any:\&'a
+for 
+.B D
+in 
+.B any
+\&.
+ *) 
+ }
+.B -> 
+.B any
+.I "  "
+  (* Constructor D documentation
+ *)
+ 
+.sp
+A gadt constructor
+
+.sp
+
+.I exception Error 
+.B of {
+ name : 
+.B string
+;  (* Error field documentation 
+.B name:string
+
+ *) 
+ }
+
+.sp
+
+.sp
+.I type ext 
++=
+ | E
+.B of {
+ yet_another_field : 
+.B unit
+;  (* Field documentation for 
+.B E
+in ext
+ *) 
+ }
+.I "  "
+(* Constructor E documentation
+ *)
+ | F
+.B of {
+ even_more : 
+.B int -> int
+;  (* Some field documentations for 
+.B F
+
+ *) 
+ }
+.I "  "
+(* Constructor F documentation
+ *)
+ | G
+.B of {
+ last : 
+.B int -> int
+;  (* The last and least field documentation
+ *) 
+ }
+.I "  "
+(* Constructor G documentation
+ *)
+ 
+.sp
+Two new constructors for ext
+
+.sp
diff --git a/testsuite/tests/tool-ocamldoc-man/Makefile b/testsuite/tests/tool-ocamldoc-man/Makefile
new file mode 100644
index 00000000..a3c272a1
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-man/Makefile
@@ -0,0 +1,54 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+COMPFLAGS=-I $(OTOPDIR)/ocamldoc
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/str
+DOCFLAGS=-I $(OTOPDIR)/stdlib $(COMPFLAGS)\
+	-latextitle "6,subsection*" \
+	-latextitle "7,subsubsection*" \
+	-latex-type-prefix "TYP" \
+	-latex-module-prefix "" \
+	-latex-module-type-prefix "" \
+	-latex-value-prefix ""
+
+.PHONY: default
+default:
+	@if ! $(SUPPORTS_SHARED_LIBRARIES); then \
+	  echo 'skipped (shared libraries not available)'; \
+	else \
+	  $(SET_LD_PATH) $(MAKE) run; \
+	fi
+
+.PHONY: run
+run: *.mli
+	@for file in *.mli; do \
+	  printf " ... testing '$$file'"; \
+	  F="`basename $$file .mli`"; \
+	  $(OCAMLDOC) $(DOCFLAGS) -hide-warnings -man $ \
+	              -o index $$file; \
+	  tail -n +2 $$F.3o > $$F.result; \
+	  $(DIFF) $$F.reference $$F.result >/dev/null \
+	  && echo " => passed" || echo " => failed"; \
+	done
+
+.PHONY: promote
+promote: defaultpromote
+
+.PHONY: clean
+clean: defaultclean
+	@rm -f *.result *.html *.tex *.log *.out *.sty *.toc *.css *.aux *.3o
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/tool-ocamldoc-open/Makefile b/testsuite/tests/tool-ocamldoc-open/Makefile
new file mode 100644
index 00000000..f54566af
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-open/Makefile
@@ -0,0 +1,47 @@
+BASEDIR=../..
+COMPFLAGS=-I $(OTOPDIR)/ocamldoc
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/str
+DOCFLAGS=-I $(OTOPDIR)/stdlib $(COMPFLAGS)
+
+SRC= main.ml alias.ml inner.ml
+ODOCS=$(SRC:%.ml=%.odoc)
+
+.PHONY: default
+default:
+	@if ! $(SUPPORTS_SHARED_LIBRARIES); then \
+	  echo 'skipped (shared libraries not available)'; \
+	else \
+	  $(SET_LD_PATH) $(MAKE) doc; \
+	fi
+
+.PHONY: doc
+doc: $(ODOCS)
+	@printf " ... testing ocamldoc '-open' option";\
+	$(OCAMLDOC) $(DOCFLAGS) -hide-warnings \
+         -load alias.odoc -load inner.odoc \
+         -load main.odoc -latex -o doc.result ;\
+	$(DIFF) doc.result doc.reference > /dev/null \
+	&& echo " => passed" || echo " => failed";
+
+inner.odoc: inner.ml
+	@$(OCAMLDOC) $(DOCFLAGS) -hide-warnings \
+        -dump inner.odoc inner.ml
+
+alias.odoc: inner.cmi alias.ml
+	@$(OCAMLDOC) $(DOCFLAGS) -hide-warnings \
+        -dump alias.odoc alias.ml
+
+main.odoc: alias.cmi main.ml
+	@$(OCAMLDOC) $(DOCFLAGS) -hide-warnings \
+        -open Alias -open Aliased_inner -dump main.odoc main.ml
+
+alias.cmi:inner.cmi
+
+.PHONY: promote
+promote: defaultpromote
+
+.PHONY: clean
+clean: defaultclean
+	@rm -f *.odoc *.toc *.sty *.aux *.log *.result
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/tool-ocamldoc-open/Readme b/testsuite/tests/tool-ocamldoc-open/Readme
new file mode 100644
index 00000000..e140d57c
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-open/Readme
@@ -0,0 +1,12 @@
+This test focuses on ocamldoc "-open" command line option.
+It ensures that the modules passed as argument to this "-open" option
+are opened in the initial environment of ocamldoc.
+
+More precisely, it checks that
+
+* both cmi files and inner modules can be opened
+* modules are opened in the left-to-right order
+
+The test builds a latex documentation file for the three modules
+"Main", "Alias" and "Inner". Changes to ocamldoc latex output might
+trigger spurious errors in this test.
diff --git a/testsuite/tests/tool-ocamldoc-open/alias.ml b/testsuite/tests/tool-ocamldoc-open/alias.ml
new file mode 100644
index 00000000..50a8f4fa
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-open/alias.ml
@@ -0,0 +1 @@
+module Aliased_inner = Inner
diff --git a/testsuite/tests/tool-ocamldoc-open/doc.reference b/testsuite/tests/tool-ocamldoc-open/doc.reference
new file mode 100644
index 00000000..c372d156
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-open/doc.reference
@@ -0,0 +1,61 @@
+\documentclass[11pt]{article} 
+\usepackage[latin1]{inputenc} 
+\usepackage[T1]{fontenc} 
+\usepackage{textcomp}
+\usepackage{fullpage} 
+\usepackage{url} 
+\usepackage{ocamldoc}
+\begin{document}
+\tableofcontents
+\section{Module {\tt{Alias}}}
+\label{module:Alias}\index{Alias@\verb`Alias`}
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\begin{ocamldoccode}
+{\tt{module }}{\tt{Aliased\_inner}}{\tt{ : }}\end{ocamldoccode}
+\label{module:Alias.Aliased-underscoreinner}\index{Aliased-underscoreinner@\verb`Aliased_inner`}
+
+{\tt{Inner}}
+
+
+
+\section{Module {\tt{Inner}}}
+\label{module:Inner}\index{Inner@\verb`Inner`}
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\label{type:Inner.a}\begin{ocamldoccode}
+type a = int 
+\end{ocamldoccode}
+\index{a@\verb`a`}
+
+
+\section{Module {\tt{Main}} : Documentation test}
+\label{module:Main}\index{Main@\verb`Main`}
+
+
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\label{type:Main.t}\begin{ocamldoccode}
+type t = Alias.Aliased_inner.a 
+\end{ocamldoccode}
+\index{t@\verb`t`}
+\begin{ocamldocdescription}
+Alias to type Inner.a
+
+
+\end{ocamldocdescription}
+
+
+\end{document}
\ No newline at end of file
diff --git a/testsuite/tests/tool-ocamldoc-open/inner.ml b/testsuite/tests/tool-ocamldoc-open/inner.ml
new file mode 100644
index 00000000..87778638
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-open/inner.ml
@@ -0,0 +1,2 @@
+
+type a = int
diff --git a/testsuite/tests/tool-ocamldoc-open/main.ml b/testsuite/tests/tool-ocamldoc-open/main.ml
new file mode 100644
index 00000000..abc1f818
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-open/main.ml
@@ -0,0 +1,5 @@
+
+(** Documentation test *)
+
+type t = a
+(** Alias to type Inner.a *)
diff --git a/testsuite/tests/tool-ocamldoc/odoc_test.ml b/testsuite/tests/tool-ocamldoc/odoc_test.ml
index 9e34bb2a..068f1e09 100644
--- a/testsuite/tests/tool-ocamldoc/odoc_test.ml
+++ b/testsuite/tests/tool-ocamldoc/odoc_test.ml
@@ -1,15 +1,3 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                             OCamldoc                                *)
-(*                                                                     *)
-(*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
-(*                                                                     *)
-(*  Copyright 2004 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
 (** Custom generator to perform test on ocamldoc. *)
 
 open Odoc_info
diff --git a/testsuite/tests/tool-ocamldoc/t04.ml b/testsuite/tests/tool-ocamldoc/t04.ml
new file mode 100644
index 00000000..97782ae6
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc/t04.ml
@@ -0,0 +1,20 @@
+(** Testing display of inline record.
+
+   @test_types_display
+ *)
+
+
+module A = struct
+  type a = A of {lbl:int}
+
+end
+
+module type E = sig
+  exception E of {lbl:int}
+
+end
+
+
+module E_bis= struct
+  exception E of {lbl:int}
+end
diff --git a/testsuite/tests/tool-ocamldoc/t04.reference b/testsuite/tests/tool-ocamldoc/t04.reference
new file mode 100644
index 00000000..924503ea
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc/t04.reference
@@ -0,0 +1,27 @@
+#
+# module T04:
+# Odoc_info.string_of_module_type:
+<[sig  end]>
+# Odoc_info.string_of_module_type ~complete: true :
+<[sig  end]>
+#
+# module T04.A:
+# Odoc_info.string_of_module_type:
+<[sig  end]>
+# Odoc_info.string_of_module_type ~complete: true :
+<[sig type a = A of { lbl : int; } end]>
+# type T04.A.a:
+# manifest (Odoc_info.string_of_type_expr):
+<[None]>
+#
+# module type T04.E:
+# Odoc_info.string_of_module_type:
+<[sig  end]>
+# Odoc_info.string_of_module_type ~complete: true :
+<[sig exception E of { lbl : int; } end]>
+#
+# module T04.E_bis:
+# Odoc_info.string_of_module_type:
+<[sig  end]>
+# Odoc_info.string_of_module_type ~complete: true :
+<[sig exception E of { lbl : int; } end]>
diff --git a/testsuite/tests/translprim/comparison_table.ml.reference b/testsuite/tests/translprim/comparison_table.ml.reference
index 22d533ec..525ff898 100644
--- a/testsuite/tests/translprim/comparison_table.ml.reference
+++ b/testsuite/tests/translprim/comparison_table.ml.reference
@@ -1,381 +1,364 @@
 (setglobal Comparison_table!
-  (seq (opaque (global List!))
-    (let
-      (gen_cmp = (function x y (caml_compare x y))
-       int_cmp =
-         (function x y (caml_int_compare x y))
-       bool_cmp =
-         (function x y (caml_int_compare x y))
-       intlike_cmp =
-         (function x y (caml_int_compare x y))
-       float_cmp =
-         (function x y (caml_float_compare x y))
-       string_cmp =
-         (function x y (caml_string_compare x y))
-       int32_cmp =
-         (function x y (caml_int32_compare x y))
-       int64_cmp =
-         (function x y (caml_int64_compare x y))
-       nativeint_cmp =
-         (function x y (caml_nativeint_compare x y))
-       gen_eq = (function x y (caml_equal x y))
-       int_eq = (function x y (== x y))
-       bool_eq = (function x y (== x y))
-       intlike_eq = (function x y (== x y))
-       float_eq = (function x y (==. x y))
-       string_eq =
-         (function x y (caml_string_equal x y))
-       int32_eq = (function x y (Int32.== x y))
-       int64_eq = (function x y (Int64.== x y))
-       nativeint_eq =
-         (function x y (Nativeint.== x y))
-       gen_ne = (function x y (caml_notequal x y))
-       int_ne = (function x y (!= x y))
-       bool_ne = (function x y (!= x y))
-       intlike_ne = (function x y (!= x y))
-       float_ne = (function x y (!=. x y))
-       string_ne =
-         (function x y (caml_string_notequal x y))
-       int32_ne = (function x y (Int32.!= x y))
-       int64_ne = (function x y (Int64.!= x y))
-       nativeint_ne =
-         (function x y (Nativeint.!= x y))
-       gen_lt = (function x y (caml_lessthan x y))
-       int_lt = (function x y (< x y))
-       bool_lt = (function x y (< x y))
-       intlike_lt = (function x y (< x y))
-       float_lt = (function x y (<. x y))
-       string_lt =
-         (function x y (caml_string_lessthan x y))
-       int32_lt = (function x y (Int32.< x y))
-       int64_lt = (function x y (Int64.< x y))
-       nativeint_lt =
-         (function x y (Nativeint.< x y))
-       gen_gt =
-         (function x y (caml_greaterthan x y))
-       int_gt = (function x y (> x y))
-       bool_gt = (function x y (> x y))
-       intlike_gt = (function x y (> x y))
-       float_gt = (function x y (>. x y))
-       string_gt =
-         (function x y (caml_string_greaterthan x y))
-       int32_gt = (function x y (Int32.> x y))
-       int64_gt = (function x y (Int64.> x y))
-       nativeint_gt =
-         (function x y (Nativeint.> x y))
-       gen_le = (function x y (caml_lessequal x y))
-       int_le = (function x y (<= x y))
-       bool_le = (function x y (<= x y))
-       intlike_le = (function x y (<= x y))
-       float_le = (function x y (<=. x y))
-       string_le =
-         (function x y (caml_string_lessequal x y))
-       int32_le = (function x y (Int32.<= x y))
-       int64_le = (function x y (Int64.<= x y))
-       nativeint_le =
-         (function x y (Nativeint.<= x y))
-       gen_ge =
-         (function x y (caml_greaterequal x y))
-       int_ge = (function x y (>= x y))
-       bool_ge = (function x y (>= x y))
-       intlike_ge = (function x y (>= x y))
-       float_ge = (function x y (>=. x y))
-       string_ge =
-         (function x y (caml_string_greaterequal x y))
-       int32_ge = (function x y (Int32.>= x y))
-       int64_ge = (function x y (Int64.>= x y))
-       nativeint_ge =
-         (function x y (Nativeint.>= x y))
-       eta_gen_cmp =
-         (function prim prim (caml_compare prim prim))
-       eta_int_cmp =
-         (function prim prim
-           (caml_int_compare prim prim))
-       eta_bool_cmp =
-         (function prim prim
-           (caml_int_compare prim prim))
-       eta_intlike_cmp =
-         (function prim prim
-           (caml_int_compare prim prim))
-       eta_float_cmp =
-         (function prim prim
-           (caml_float_compare prim prim))
-       eta_string_cmp =
-         (function prim prim
-           (caml_string_compare prim prim))
-       eta_int32_cmp =
-         (function prim prim
-           (caml_int32_compare prim prim))
-       eta_int64_cmp =
-         (function prim prim
-           (caml_int64_compare prim prim))
-       eta_nativeint_cmp =
-         (function prim prim
-           (caml_nativeint_compare prim prim))
-       eta_gen_eq =
-         (function prim prim (caml_equal prim prim))
-       eta_int_eq =
-         (function prim prim (== prim prim))
-       eta_bool_eq =
-         (function prim prim (== prim prim))
-       eta_intlike_eq =
-         (function prim prim (== prim prim))
-       eta_float_eq =
-         (function prim prim (==. prim prim))
-       eta_string_eq =
-         (function prim prim
-           (caml_string_equal prim prim))
-       eta_int32_eq =
-         (function prim prim (Int32.== prim prim))
-       eta_int64_eq =
-         (function prim prim (Int64.== prim prim))
-       eta_nativeint_eq =
-         (function prim prim (Nativeint.== prim prim))
-       eta_gen_ne =
-         (function prim prim (caml_notequal prim prim))
-       eta_int_ne =
-         (function prim prim (!= prim prim))
-       eta_bool_ne =
-         (function prim prim (!= prim prim))
-       eta_intlike_ne =
-         (function prim prim (!= prim prim))
-       eta_float_ne =
-         (function prim prim (!=. prim prim))
-       eta_string_ne =
-         (function prim prim
-           (caml_string_notequal prim prim))
-       eta_int32_ne =
-         (function prim prim (Int32.!= prim prim))
-       eta_int64_ne =
-         (function prim prim (Int64.!= prim prim))
-       eta_nativeint_ne =
-         (function prim prim (Nativeint.!= prim prim))
-       eta_gen_lt =
-         (function prim prim (caml_lessthan prim prim))
-       eta_int_lt =
-         (function prim prim (< prim prim))
-       eta_bool_lt =
-         (function prim prim (< prim prim))
-       eta_intlike_lt =
-         (function prim prim (< prim prim))
-       eta_float_lt =
-         (function prim prim (<. prim prim))
-       eta_string_lt =
-         (function prim prim
-           (caml_string_lessthan prim prim))
-       eta_int32_lt =
-         (function prim prim (Int32.< prim prim))
-       eta_int64_lt =
-         (function prim prim (Int64.< prim prim))
-       eta_nativeint_lt =
-         (function prim prim (Nativeint.< prim prim))
-       eta_gen_gt =
-         (function prim prim
-           (caml_greaterthan prim prim))
-       eta_int_gt =
-         (function prim prim (> prim prim))
-       eta_bool_gt =
-         (function prim prim (> prim prim))
-       eta_intlike_gt =
-         (function prim prim (> prim prim))
-       eta_float_gt =
-         (function prim prim (>. prim prim))
-       eta_string_gt =
-         (function prim prim
-           (caml_string_greaterthan prim prim))
-       eta_int32_gt =
-         (function prim prim (Int32.> prim prim))
-       eta_int64_gt =
-         (function prim prim (Int64.> prim prim))
-       eta_nativeint_gt =
-         (function prim prim (Nativeint.> prim prim))
-       eta_gen_le =
-         (function prim prim (caml_lessequal prim prim))
-       eta_int_le =
-         (function prim prim (<= prim prim))
-       eta_bool_le =
-         (function prim prim (<= prim prim))
-       eta_intlike_le =
-         (function prim prim (<= prim prim))
-       eta_float_le =
-         (function prim prim (<=. prim prim))
-       eta_string_le =
-         (function prim prim
-           (caml_string_lessequal prim prim))
-       eta_int32_le =
-         (function prim prim (Int32.<= prim prim))
-       eta_int64_le =
-         (function prim prim (Int64.<= prim prim))
-       eta_nativeint_le =
-         (function prim prim (Nativeint.<= prim prim))
-       eta_gen_ge =
-         (function prim prim
-           (caml_greaterequal prim prim))
-       eta_int_ge =
-         (function prim prim (>= prim prim))
-       eta_bool_ge =
-         (function prim prim (>= prim prim))
-       eta_intlike_ge =
-         (function prim prim (>= prim prim))
-       eta_float_ge =
-         (function prim prim (>=. prim prim))
-       eta_string_ge =
-         (function prim prim
-           (caml_string_greaterequal prim prim))
-       eta_int32_ge =
-         (function prim prim (Int32.>= prim prim))
-       eta_int64_ge =
-         (function prim prim (Int64.>= prim prim))
-       eta_nativeint_ge =
-         (function prim prim (Nativeint.>= prim prim))
-       int_vec = [0: [0: 1 1] [0: [0: 1 2] [0: [0: 2 1] 0a]]]
-       bool_vec = [0: [0: 0a 0a] [0: [0: 0a 1a] [0: [0: 1a 0a] 0a]]]
-       intlike_vec = [0: [0: 0a 0a] [0: [0: 0a 1a] [0: [0: 1a 0a] 0a]]]
-       float_vec = [0: [0: 1. 1.] [0: [0: 1. 2.] [0: [0: 2. 1.] 0a]]]
-       string_vec =
-         [0: [0: "1" "1"] [0: [0: "1" "2"] [0: [0: "2" "1"] 0a]]]
-       int32_vec = [0: [0: 1l 1l] [0: [0: 1l 2l] [0: [0: 2l 1l] 0a]]]
-       int64_vec = [0: [0: 1L 1L] [0: [0: 1L 2L] [0: [0: 2L 1L] 0a]]]
-       nativeint_vec =
-         [0: [0: 1n 1n] [0: [0: 1n 2n] [0: [0: 2n 1n] 0a]]]
-       test_vec =
-         (function cmp eq ne lt gt le ge
-           vec
-           (let
-             (uncurry =
-                (function f param
-                  (apply f (field 0 param) (field 1 param)))
-              map =
-                (function f l
-                  (apply (field 12 (global List!))
-                    (apply uncurry f) l)))
-             (makeblock 0
-               (makeblock 0 (apply map gen_cmp vec)
-                 (apply map cmp vec))
-               (apply map
-                 (function gen spec
-                   (makeblock 0 (apply map gen vec)
-                     (apply map spec vec)))
-                 (makeblock 0 (makeblock 0 gen_eq eq)
-                   (makeblock 0 (makeblock 0 gen_ne ne)
-                     (makeblock 0 (makeblock 0 gen_lt lt)
-                       (makeblock 0 (makeblock 0 gen_gt gt)
-                         (makeblock 0 (makeblock 0 gen_le le)
-                           (makeblock 0 (makeblock 0 gen_ge ge) 0a)))))))))))
-      (seq
-        (apply test_vec int_cmp int_eq int_ne int_lt
-          int_gt int_le int_ge int_vec)
-        (apply test_vec bool_cmp bool_eq bool_ne
-          bool_lt bool_gt bool_le bool_ge bool_vec)
-        (apply test_vec intlike_cmp intlike_eq intlike_ne
-          intlike_lt intlike_gt intlike_le intlike_ge
-          intlike_vec)
-        (apply test_vec float_cmp float_eq float_ne
-          float_lt float_gt float_le float_ge
-          float_vec)
-        (apply test_vec string_cmp string_eq string_ne
-          string_lt string_gt string_le string_ge
-          string_vec)
-        (apply test_vec int32_cmp int32_eq int32_ne
-          int32_lt int32_gt int32_le int32_ge
-          int32_vec)
-        (apply test_vec int64_cmp int64_eq int64_ne
-          int64_lt int64_gt int64_le int64_ge
-          int64_vec)
-        (apply test_vec nativeint_cmp nativeint_eq
-          nativeint_ne nativeint_lt nativeint_gt
-          nativeint_le nativeint_ge nativeint_vec)
-        (let
-          (eta_test_vec =
-             (function cmp eq ne lt gt le
-               ge vec
-               (let
-                 (uncurry =
-                    (function f param
-                      (apply f (field 0 param)
-                        (field 1 param)))
-                  map =
-                    (function f l
-                      (apply (field 12 (global List!))
-                        (apply uncurry f) l)))
-                 (makeblock 0
-                   (makeblock 0 (apply map eta_gen_cmp vec)
-                     (apply map cmp vec))
-                   (apply map
-                     (function gen spec
-                       (makeblock 0 (apply map gen vec)
-                         (apply map spec vec)))
-                     (makeblock 0 (makeblock 0 eta_gen_eq eq)
-                       (makeblock 0 (makeblock 0 eta_gen_ne ne)
-                         (makeblock 0 (makeblock 0 eta_gen_lt lt)
-                           (makeblock 0 (makeblock 0 eta_gen_gt gt)
+  (let
+    (gen_cmp = (function x y (caml_compare x y))
+     int_cmp = (function x y (caml_int_compare x y))
+     bool_cmp =
+       (function x y (caml_int_compare x y))
+     intlike_cmp =
+       (function x y (caml_int_compare x y))
+     float_cmp =
+       (function x y (caml_float_compare x y))
+     string_cmp =
+       (function x y (caml_string_compare x y))
+     int32_cmp =
+       (function x y (caml_int32_compare x y))
+     int64_cmp =
+       (function x y (caml_int64_compare x y))
+     nativeint_cmp =
+       (function x y (caml_nativeint_compare x y))
+     gen_eq = (function x y (caml_equal x y))
+     int_eq = (function x y (== x y))
+     bool_eq = (function x y (== x y))
+     intlike_eq = (function x y (== x y))
+     float_eq = (function x y (==. x y))
+     string_eq =
+       (function x y (caml_string_equal x y))
+     int32_eq = (function x y (Int32.== x y))
+     int64_eq = (function x y (Int64.== x y))
+     nativeint_eq =
+       (function x y (Nativeint.== x y))
+     gen_ne = (function x y (caml_notequal x y))
+     int_ne = (function x y (!= x y))
+     bool_ne = (function x y (!= x y))
+     intlike_ne = (function x y (!= x y))
+     float_ne = (function x y (!=. x y))
+     string_ne =
+       (function x y (caml_string_notequal x y))
+     int32_ne = (function x y (Int32.!= x y))
+     int64_ne = (function x y (Int64.!= x y))
+     nativeint_ne =
+       (function x y (Nativeint.!= x y))
+     gen_lt = (function x y (caml_lessthan x y))
+     int_lt = (function x y (< x y))
+     bool_lt = (function x y (< x y))
+     intlike_lt = (function x y (< x y))
+     float_lt = (function x y (<. x y))
+     string_lt =
+       (function x y (caml_string_lessthan x y))
+     int32_lt = (function x y (Int32.< x y))
+     int64_lt = (function x y (Int64.< x y))
+     nativeint_lt = (function x y (Nativeint.< x y))
+     gen_gt = (function x y (caml_greaterthan x y))
+     int_gt = (function x y (> x y))
+     bool_gt = (function x y (> x y))
+     intlike_gt = (function x y (> x y))
+     float_gt = (function x y (>. x y))
+     string_gt =
+       (function x y (caml_string_greaterthan x y))
+     int32_gt = (function x y (Int32.> x y))
+     int64_gt = (function x y (Int64.> x y))
+     nativeint_gt = (function x y (Nativeint.> x y))
+     gen_le = (function x y (caml_lessequal x y))
+     int_le = (function x y (<= x y))
+     bool_le = (function x y (<= x y))
+     intlike_le = (function x y (<= x y))
+     float_le = (function x y (<=. x y))
+     string_le =
+       (function x y (caml_string_lessequal x y))
+     int32_le = (function x y (Int32.<= x y))
+     int64_le = (function x y (Int64.<= x y))
+     nativeint_le =
+       (function x y (Nativeint.<= x y))
+     gen_ge = (function x y (caml_greaterequal x y))
+     int_ge = (function x y (>= x y))
+     bool_ge = (function x y (>= x y))
+     intlike_ge = (function x y (>= x y))
+     float_ge = (function x y (>=. x y))
+     string_ge =
+       (function x y (caml_string_greaterequal x y))
+     int32_ge = (function x y (Int32.>= x y))
+     int64_ge = (function x y (Int64.>= x y))
+     nativeint_ge =
+       (function x y (Nativeint.>= x y))
+     eta_gen_cmp =
+       (function prim prim (caml_compare prim prim))
+     eta_int_cmp =
+       (function prim prim (caml_int_compare prim prim))
+     eta_bool_cmp =
+       (function prim prim (caml_int_compare prim prim))
+     eta_intlike_cmp =
+       (function prim prim (caml_int_compare prim prim))
+     eta_float_cmp =
+       (function prim prim
+         (caml_float_compare prim prim))
+     eta_string_cmp =
+       (function prim prim
+         (caml_string_compare prim prim))
+     eta_int32_cmp =
+       (function prim prim
+         (caml_int32_compare prim prim))
+     eta_int64_cmp =
+       (function prim prim
+         (caml_int64_compare prim prim))
+     eta_nativeint_cmp =
+       (function prim prim
+         (caml_nativeint_compare prim prim))
+     eta_gen_eq =
+       (function prim prim (caml_equal prim prim))
+     eta_int_eq =
+       (function prim prim (== prim prim))
+     eta_bool_eq =
+       (function prim prim (== prim prim))
+     eta_intlike_eq =
+       (function prim prim (== prim prim))
+     eta_float_eq =
+       (function prim prim (==. prim prim))
+     eta_string_eq =
+       (function prim prim (caml_string_equal prim prim))
+     eta_int32_eq =
+       (function prim prim (Int32.== prim prim))
+     eta_int64_eq =
+       (function prim prim (Int64.== prim prim))
+     eta_nativeint_eq =
+       (function prim prim (Nativeint.== prim prim))
+     eta_gen_ne =
+       (function prim prim (caml_notequal prim prim))
+     eta_int_ne =
+       (function prim prim (!= prim prim))
+     eta_bool_ne =
+       (function prim prim (!= prim prim))
+     eta_intlike_ne =
+       (function prim prim (!= prim prim))
+     eta_float_ne =
+       (function prim prim (!=. prim prim))
+     eta_string_ne =
+       (function prim prim
+         (caml_string_notequal prim prim))
+     eta_int32_ne =
+       (function prim prim (Int32.!= prim prim))
+     eta_int64_ne =
+       (function prim prim (Int64.!= prim prim))
+     eta_nativeint_ne =
+       (function prim prim (Nativeint.!= prim prim))
+     eta_gen_lt =
+       (function prim prim (caml_lessthan prim prim))
+     eta_int_lt = (function prim prim (< prim prim))
+     eta_bool_lt =
+       (function prim prim (< prim prim))
+     eta_intlike_lt =
+       (function prim prim (< prim prim))
+     eta_float_lt =
+       (function prim prim (<. prim prim))
+     eta_string_lt =
+       (function prim prim
+         (caml_string_lessthan prim prim))
+     eta_int32_lt =
+       (function prim prim (Int32.< prim prim))
+     eta_int64_lt =
+       (function prim prim (Int64.< prim prim))
+     eta_nativeint_lt =
+       (function prim prim (Nativeint.< prim prim))
+     eta_gen_gt =
+       (function prim prim (caml_greaterthan prim prim))
+     eta_int_gt = (function prim prim (> prim prim))
+     eta_bool_gt =
+       (function prim prim (> prim prim))
+     eta_intlike_gt =
+       (function prim prim (> prim prim))
+     eta_float_gt =
+       (function prim prim (>. prim prim))
+     eta_string_gt =
+       (function prim prim
+         (caml_string_greaterthan prim prim))
+     eta_int32_gt =
+       (function prim prim (Int32.> prim prim))
+     eta_int64_gt =
+       (function prim prim (Int64.> prim prim))
+     eta_nativeint_gt =
+       (function prim prim (Nativeint.> prim prim))
+     eta_gen_le =
+       (function prim prim (caml_lessequal prim prim))
+     eta_int_le =
+       (function prim prim (<= prim prim))
+     eta_bool_le =
+       (function prim prim (<= prim prim))
+     eta_intlike_le =
+       (function prim prim (<= prim prim))
+     eta_float_le =
+       (function prim prim (<=. prim prim))
+     eta_string_le =
+       (function prim prim
+         (caml_string_lessequal prim prim))
+     eta_int32_le =
+       (function prim prim (Int32.<= prim prim))
+     eta_int64_le =
+       (function prim prim (Int64.<= prim prim))
+     eta_nativeint_le =
+       (function prim prim (Nativeint.<= prim prim))
+     eta_gen_ge =
+       (function prim prim (caml_greaterequal prim prim))
+     eta_int_ge =
+       (function prim prim (>= prim prim))
+     eta_bool_ge =
+       (function prim prim (>= prim prim))
+     eta_intlike_ge =
+       (function prim prim (>= prim prim))
+     eta_float_ge =
+       (function prim prim (>=. prim prim))
+     eta_string_ge =
+       (function prim prim
+         (caml_string_greaterequal prim prim))
+     eta_int32_ge =
+       (function prim prim (Int32.>= prim prim))
+     eta_int64_ge =
+       (function prim prim (Int64.>= prim prim))
+     eta_nativeint_ge =
+       (function prim prim (Nativeint.>= prim prim))
+     int_vec = [0: [0: 1 1] [0: [0: 1 2] [0: [0: 2 1] 0a]]]
+     bool_vec = [0: [0: 0a 0a] [0: [0: 0a 1a] [0: [0: 1a 0a] 0a]]]
+     intlike_vec = [0: [0: 0a 0a] [0: [0: 0a 1a] [0: [0: 1a 0a] 0a]]]
+     float_vec = [0: [0: 1. 1.] [0: [0: 1. 2.] [0: [0: 2. 1.] 0a]]]
+     string_vec =
+       [0: [0: "1" "1"] [0: [0: "1" "2"] [0: [0: "2" "1"] 0a]]]
+     int32_vec = [0: [0: 1l 1l] [0: [0: 1l 2l] [0: [0: 2l 1l] 0a]]]
+     int64_vec = [0: [0: 1L 1L] [0: [0: 1L 2L] [0: [0: 2L 1L] 0a]]]
+     nativeint_vec = [0: [0: 1n 1n] [0: [0: 1n 2n] [0: [0: 2n 1n] 0a]]]
+     test_vec =
+       (function cmp eq ne lt gt le ge
+         vec
+         (let
+           (uncurry =
+              (function f param
+                (apply f (field 0 param) (field 1 param)))
+            map =
+              (function f l
+                (apply (field 12 (global List!)) (apply uncurry f)
+                  l)))
+           (makeblock 0
+             (makeblock 0 (apply map gen_cmp vec)
+               (apply map cmp vec))
+             (apply map
+               (function gen spec
+                 (makeblock 0 (apply map gen vec)
+                   (apply map spec vec)))
+               (makeblock 0 (makeblock 0 gen_eq eq)
+                 (makeblock 0 (makeblock 0 gen_ne ne)
+                   (makeblock 0 (makeblock 0 gen_lt lt)
+                     (makeblock 0 (makeblock 0 gen_gt gt)
+                       (makeblock 0 (makeblock 0 gen_le le)
+                         (makeblock 0 (makeblock 0 gen_ge ge) 0a)))))))))))
+    (seq
+      (apply test_vec int_cmp int_eq int_ne int_lt
+        int_gt int_le int_ge int_vec)
+      (apply test_vec bool_cmp bool_eq bool_ne
+        bool_lt bool_gt bool_le bool_ge bool_vec)
+      (apply test_vec intlike_cmp intlike_eq intlike_ne
+        intlike_lt intlike_gt intlike_le intlike_ge
+        intlike_vec)
+      (apply test_vec float_cmp float_eq float_ne
+        float_lt float_gt float_le float_ge
+        float_vec)
+      (apply test_vec string_cmp string_eq string_ne
+        string_lt string_gt string_le string_ge
+        string_vec)
+      (apply test_vec int32_cmp int32_eq int32_ne
+        int32_lt int32_gt int32_le int32_ge
+        int32_vec)
+      (apply test_vec int64_cmp int64_eq int64_ne
+        int64_lt int64_gt int64_le int64_ge
+        int64_vec)
+      (apply test_vec nativeint_cmp nativeint_eq
+        nativeint_ne nativeint_lt nativeint_gt
+        nativeint_le nativeint_ge nativeint_vec)
+      (let
+        (eta_test_vec =
+           (function cmp eq ne lt gt le ge
+             vec
+             (let
+               (uncurry =
+                  (function f param
+                    (apply f (field 0 param) (field 1 param)))
+                map =
+                  (function f l
+                    (apply (field 12 (global List!))
+                      (apply uncurry f) l)))
+               (makeblock 0
+                 (makeblock 0 (apply map eta_gen_cmp vec)
+                   (apply map cmp vec))
+                 (apply map
+                   (function gen spec
+                     (makeblock 0 (apply map gen vec)
+                       (apply map spec vec)))
+                   (makeblock 0 (makeblock 0 eta_gen_eq eq)
+                     (makeblock 0 (makeblock 0 eta_gen_ne ne)
+                       (makeblock 0 (makeblock 0 eta_gen_lt lt)
+                         (makeblock 0 (makeblock 0 eta_gen_gt gt)
+                           (makeblock 0 (makeblock 0 eta_gen_le le)
                              (makeblock 0
-                               (makeblock 0 eta_gen_le le)
-                               (makeblock 0
-                                 (makeblock 0 eta_gen_ge ge) 0a)))))))))))
-          (seq
-            (apply eta_test_vec eta_int_cmp eta_int_eq
-              eta_int_ne eta_int_lt eta_int_gt eta_int_le
-              eta_int_ge int_vec)
-            (apply eta_test_vec eta_bool_cmp eta_bool_eq
-              eta_bool_ne eta_bool_lt eta_bool_gt
-              eta_bool_le eta_bool_ge bool_vec)
-            (apply eta_test_vec eta_intlike_cmp eta_intlike_eq
-              eta_intlike_ne eta_intlike_lt eta_intlike_gt
-              eta_intlike_le eta_intlike_ge intlike_vec)
-            (apply eta_test_vec eta_float_cmp eta_float_eq
-              eta_float_ne eta_float_lt eta_float_gt
-              eta_float_le eta_float_ge float_vec)
-            (apply eta_test_vec eta_string_cmp eta_string_eq
-              eta_string_ne eta_string_lt eta_string_gt
-              eta_string_le eta_string_ge string_vec)
-            (apply eta_test_vec eta_int32_cmp eta_int32_eq
-              eta_int32_ne eta_int32_lt eta_int32_gt
-              eta_int32_le eta_int32_ge int32_vec)
-            (apply eta_test_vec eta_int64_cmp eta_int64_eq
-              eta_int64_ne eta_int64_lt eta_int64_gt
-              eta_int64_le eta_int64_ge int64_vec)
-            (apply eta_test_vec eta_nativeint_cmp
-              eta_nativeint_eq eta_nativeint_ne
-              eta_nativeint_lt eta_nativeint_gt
-              eta_nativeint_le eta_nativeint_ge nativeint_vec)
-            (makeblock 0 gen_cmp int_cmp bool_cmp
-              intlike_cmp float_cmp string_cmp int32_cmp
-              int64_cmp nativeint_cmp gen_eq int_eq
-              bool_eq intlike_eq float_eq string_eq
-              int32_eq int64_eq nativeint_eq gen_ne
-              int_ne bool_ne intlike_ne float_ne
-              string_ne int32_ne int64_ne nativeint_ne
-              gen_lt int_lt bool_lt intlike_lt
-              float_lt string_lt int32_lt int64_lt
-              nativeint_lt gen_gt int_gt bool_gt
-              intlike_gt float_gt string_gt int32_gt
-              int64_gt nativeint_gt gen_le int_le
-              bool_le intlike_le float_le string_le
-              int32_le int64_le nativeint_le gen_ge
-              int_ge bool_ge intlike_ge float_ge
-              string_ge int32_ge int64_ge nativeint_ge
-              eta_gen_cmp eta_int_cmp eta_bool_cmp
-              eta_intlike_cmp eta_float_cmp eta_string_cmp
-              eta_int32_cmp eta_int64_cmp eta_nativeint_cmp
-              eta_gen_eq eta_int_eq eta_bool_eq
-              eta_intlike_eq eta_float_eq eta_string_eq
-              eta_int32_eq eta_int64_eq eta_nativeint_eq
-              eta_gen_ne eta_int_ne eta_bool_ne
-              eta_intlike_ne eta_float_ne eta_string_ne
-              eta_int32_ne eta_int64_ne eta_nativeint_ne
-              eta_gen_lt eta_int_lt eta_bool_lt
-              eta_intlike_lt eta_float_lt eta_string_lt
-              eta_int32_lt eta_int64_lt eta_nativeint_lt
-              eta_gen_gt eta_int_gt eta_bool_gt
-              eta_intlike_gt eta_float_gt eta_string_gt
-              eta_int32_gt eta_int64_gt eta_nativeint_gt
-              eta_gen_le eta_int_le eta_bool_le
-              eta_intlike_le eta_float_le eta_string_le
-              eta_int32_le eta_int64_le eta_nativeint_le
-              eta_gen_ge eta_int_ge eta_bool_ge
-              eta_intlike_ge eta_float_ge eta_string_ge
-              eta_int32_ge eta_int64_ge eta_nativeint_ge
-              int_vec bool_vec intlike_vec float_vec
-              string_vec int32_vec int64_vec
-              nativeint_vec test_vec eta_test_vec)))))))
+                               (makeblock 0 eta_gen_ge ge) 0a)))))))))))
+        (seq
+          (apply eta_test_vec eta_int_cmp eta_int_eq
+            eta_int_ne eta_int_lt eta_int_gt eta_int_le
+            eta_int_ge int_vec)
+          (apply eta_test_vec eta_bool_cmp eta_bool_eq
+            eta_bool_ne eta_bool_lt eta_bool_gt
+            eta_bool_le eta_bool_ge bool_vec)
+          (apply eta_test_vec eta_intlike_cmp eta_intlike_eq
+            eta_intlike_ne eta_intlike_lt eta_intlike_gt
+            eta_intlike_le eta_intlike_ge intlike_vec)
+          (apply eta_test_vec eta_float_cmp eta_float_eq
+            eta_float_ne eta_float_lt eta_float_gt
+            eta_float_le eta_float_ge float_vec)
+          (apply eta_test_vec eta_string_cmp eta_string_eq
+            eta_string_ne eta_string_lt eta_string_gt
+            eta_string_le eta_string_ge string_vec)
+          (apply eta_test_vec eta_int32_cmp eta_int32_eq
+            eta_int32_ne eta_int32_lt eta_int32_gt
+            eta_int32_le eta_int32_ge int32_vec)
+          (apply eta_test_vec eta_int64_cmp eta_int64_eq
+            eta_int64_ne eta_int64_lt eta_int64_gt
+            eta_int64_le eta_int64_ge int64_vec)
+          (apply eta_test_vec eta_nativeint_cmp
+            eta_nativeint_eq eta_nativeint_ne eta_nativeint_lt
+            eta_nativeint_gt eta_nativeint_le eta_nativeint_ge
+            nativeint_vec)
+          (makeblock 0 gen_cmp int_cmp bool_cmp
+            intlike_cmp float_cmp string_cmp int32_cmp
+            int64_cmp nativeint_cmp gen_eq int_eq
+            bool_eq intlike_eq float_eq string_eq
+            int32_eq int64_eq nativeint_eq gen_ne
+            int_ne bool_ne intlike_ne float_ne
+            string_ne int32_ne int64_ne nativeint_ne
+            gen_lt int_lt bool_lt intlike_lt
+            float_lt string_lt int32_lt int64_lt
+            nativeint_lt gen_gt int_gt bool_gt
+            intlike_gt float_gt string_gt int32_gt
+            int64_gt nativeint_gt gen_le int_le
+            bool_le intlike_le float_le string_le
+            int32_le int64_le nativeint_le gen_ge
+            int_ge bool_ge intlike_ge float_ge
+            string_ge int32_ge int64_ge nativeint_ge
+            eta_gen_cmp eta_int_cmp eta_bool_cmp
+            eta_intlike_cmp eta_float_cmp eta_string_cmp
+            eta_int32_cmp eta_int64_cmp eta_nativeint_cmp
+            eta_gen_eq eta_int_eq eta_bool_eq
+            eta_intlike_eq eta_float_eq eta_string_eq
+            eta_int32_eq eta_int64_eq eta_nativeint_eq
+            eta_gen_ne eta_int_ne eta_bool_ne
+            eta_intlike_ne eta_float_ne eta_string_ne
+            eta_int32_ne eta_int64_ne eta_nativeint_ne
+            eta_gen_lt eta_int_lt eta_bool_lt
+            eta_intlike_lt eta_float_lt eta_string_lt
+            eta_int32_lt eta_int64_lt eta_nativeint_lt
+            eta_gen_gt eta_int_gt eta_bool_gt
+            eta_intlike_gt eta_float_gt eta_string_gt
+            eta_int32_gt eta_int64_gt eta_nativeint_gt
+            eta_gen_le eta_int_le eta_bool_le
+            eta_intlike_le eta_float_le eta_string_le
+            eta_int32_le eta_int64_le eta_nativeint_le
+            eta_gen_ge eta_int_ge eta_bool_ge
+            eta_intlike_ge eta_float_ge eta_string_ge
+            eta_int32_ge eta_int64_ge eta_nativeint_ge
+            int_vec bool_vec intlike_vec float_vec
+            string_vec int32_vec int64_vec nativeint_vec
+            test_vec eta_test_vec))))))
diff --git a/testsuite/tests/translprim/ref_spec.ml.reference b/testsuite/tests/translprim/ref_spec.ml.reference
index ed1784ad..c21b100b 100644
--- a/testsuite/tests/translprim/ref_spec.ml.reference
+++ b/testsuite/tests/translprim/ref_spec.ml.reference
@@ -1,23 +1,23 @@
 (setglobal Ref_spec!
   (let
-    (int_ref = (makemutable 0 1)
+    (int_ref = (makemutable 0 (int) 1)
      var_ref = (makemutable 0 65a)
      vargen_ref = (makemutable 0 65a)
      cst_ref = (makemutable 0 0a)
      gen_ref = (makemutable 0 0a)
-     flt_ref = (makemutable 0 0.))
+     flt_ref = (makemutable 0 (float) 0.))
     (seq (setfield_imm 0 int_ref 2) (setfield_imm 0 var_ref 66a)
       (setfield_ptr 0 vargen_ref [0: 66 0])
       (setfield_ptr 0 vargen_ref 67a) (setfield_imm 0 cst_ref 1a)
       (setfield_ptr 0 gen_ref [0: "foo"])
       (setfield_ptr 0 gen_ref 0a) (setfield_ptr 0 flt_ref 1.)
       (let
-        (int_rec = (makemutable 0 0a 1)
+        (int_rec = (makemutable 0 (*,int) 0a 1)
          var_rec = (makemutable 0 0a 65a)
          vargen_rec = (makemutable 0 0a 65a)
          cst_rec = (makemutable 0 0a 0a)
          gen_rec = (makemutable 0 0a 0a)
-         flt_rec = (makemutable 0 0a 0.)
+         flt_rec = (makemutable 0 (*,float) 0a 0.)
          flt_rec' = (makearray[float] 0. 0.))
         (seq (setfield_imm 1 int_rec 2)
           (setfield_imm 1 var_rec 66a)
diff --git a/testsuite/tests/typing-extensions/open_types.ml b/testsuite/tests/typing-extensions/open_types.ml
index 766bee04..c439f38a 100644
--- a/testsuite/tests/typing-extensions/open_types.ml
+++ b/testsuite/tests/typing-extensions/open_types.ml
@@ -115,3 +115,11 @@ let f = function
   | _::_::_ -> 3
   | [] -> 2
 ;; (* warn *)
+
+
+(* PR#7330: exhaustiveness with GADTs *)
+
+type t = ..
+type t += IPair : (int * int) -> t ;;
+
+let f = function IPair (i, j) -> Format.sprintf "(%d, %d)" i j ;; (* warn *)
diff --git a/testsuite/tests/typing-extensions/open_types.ml.reference b/testsuite/tests/typing-extensions/open_types.ml.reference
index 8e86ec09..a339ac7f 100644
--- a/testsuite/tests/typing-extensions/open_types.ml.reference
+++ b/testsuite/tests/typing-extensions/open_types.ml.reference
@@ -75,7 +75,7 @@ Error: Signature mismatch:
   let f = function Foo -> ()
           ^^^^^^^^^^^^^^^^^^
 Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
+Here is an example of a case that is not matched:
 *extension*
 Matching over values of extensible variant types (the *extension* above)
 must include a wild card pattern in order to be exhaustive.
@@ -88,9 +88,20 @@ val f : foo -> unit = 
     | _::_::_ -> 3
     | [] -> 2
 Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
+Here is an example of a case that is not matched:
 *extension*::[]
 Matching over values of extensible variant types (the *extension* above)
 must include a wild card pattern in order to be exhaustive.
 val f : foo list -> int = 
+#           type t = ..
+type t += IPair : (int * int) -> t
+#   Characters 9-63:
+  let f = function IPair (i, j) -> Format.sprintf "(%d, %d)" i j ;; (* warn *)
+          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+*extension*
+Matching over values of extensible variant types (the *extension* above)
+must include a wild card pattern in order to be exhaustive.
+val f : t -> string = 
 # 
diff --git a/testsuite/tests/typing-gadts/Makefile b/testsuite/tests/typing-gadts/Makefile
index 7fc00661..0b15e777 100644
--- a/testsuite/tests/typing-gadts/Makefile
+++ b/testsuite/tests/typing-gadts/Makefile
@@ -14,5 +14,5 @@
 #**************************************************************************
 
 BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.expect
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-gadts/didier.ml b/testsuite/tests/typing-gadts/didier.ml
index f34ecb67..cab57d2b 100644
--- a/testsuite/tests/typing-gadts/didier.ml
+++ b/testsuite/tests/typing-gadts/didier.ml
@@ -6,6 +6,14 @@ let fbool (type t) (x : t) (tag : t ty) =
   match tag with
   | Bool -> x
 ;;
+[%%expect{|
+type 'a ty = Int : int ty | Bool : bool ty
+Line _, characters 2-30:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Int
+val fbool : 'a -> 'a ty -> 'a = 
+|}];;
 (* val fbool : 'a -> 'a ty -> 'a =  *)
 (** OK: the return value is x of type t **)
 
@@ -13,24 +21,58 @@ let fint (type t) (x : t) (tag : t ty) =
   match tag with
   | Int -> x > 0
 ;;
+[%%expect{|
+Line _, characters 2-33:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Bool
+val fint : 'a -> 'a ty -> bool = 
+|}];;
 (* val fint : 'a -> 'a ty -> bool =  *)
 (** OK: the return value is x > 0 of type bool;
 This has used the equation t = bool, not visible in the return type **)
 
+(* not principal *)
 let f (type t) (x : t) (tag : t ty) =
   match tag with
   | Int -> x > 0
   | Bool -> x
+;;
+[%%expect{|
+val f : 'a -> 'a ty -> bool = 
+|}, Principal{|
+Line _, characters 12-13:
+Error: This expression has type t but an expression was expected of type bool
+|}];;
 (* val f : 'a -> 'a ty -> bool =  *)
 
-
+(* fail for both *)
 let g (type t) (x : t) (tag : t ty) =
   match tag with
   | Bool -> x
   | Int -> x > 0
+;;
+[%%expect{|
+Line _, characters 11-16:
+Error: This expression has type bool but an expression was expected of type
+         t = int
+|}, Principal{|
+Line _, characters 11-16:
+Error: This expression has type bool but an expression was expected of type t
+|}];;
 (* Error: This expression has type bool but an expression was expected of type
 t = int *)
 
+(* OK *)
+let g (type t) (x : t) (tag : t ty) : bool =
+  match tag with
+  | Bool -> x
+  | Int -> x > 0
+;;
+[%%expect{|
+val g : 'a -> 'a ty -> bool = 
+|}];;
+
 let id x = x;;
 let idb1 = (fun id -> let _ = id true in id) id;;
 let idb2 : bool -> bool = id;;
@@ -40,8 +82,20 @@ let g (type t) (x : t) (tag : t ty) =
   match tag with
   | Bool -> idb3 x
   | Int -> x > 0
+;;
+[%%expect{|
+val id : 'a -> 'a = 
+val idb1 : bool -> bool = 
+val idb2 : bool -> bool = 
+val idb3 : bool -> bool = 
+val g : 'a -> 'a ty -> bool = 
+|}];;
 
 let g (type t) (x : t) (tag : t ty) =
   match tag with
   | Bool -> idb2 x
   | Int -> x > 0
+;;
+[%%expect{|
+val g : 'a -> 'a ty -> bool = 
+|}];;
diff --git a/testsuite/tests/typing-gadts/didier.ml.reference b/testsuite/tests/typing-gadts/didier.ml.reference
deleted file mode 100644
index 295d38bb..00000000
--- a/testsuite/tests/typing-gadts/didier.ml.reference
+++ /dev/null
@@ -1,34 +0,0 @@
-
-#               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/dynamic_frisch.ml b/testsuite/tests/typing-gadts/dynamic_frisch.ml
index 7018bbc1..112c161b 100644
--- a/testsuite/tests/typing-gadts/dynamic_frisch.ml
+++ b/testsuite/tests/typing-gadts/dynamic_frisch.ml
@@ -18,6 +18,7 @@ type variant =
   | VString of string
   | VList of variant list
   | VPair of variant * variant
+;;
 
 let rec variantize: type t. t ty -> t -> variant =
   fun ty x ->
@@ -31,8 +32,23 @@ let rec variantize: type t. t ty -> t -> variant =
     | Pair (ty1, ty2) ->
         VPair (variantize ty1 (fst x), variantize ty2 (snd x))
         (* t = ('a, 'b) for some 'a and 'b *)
+;;
+[%%expect{|
+type 'a ty =
+    Int : int ty
+  | String : string ty
+  | List : 'a ty -> 'a list ty
+  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
+type variant =
+    VInt of int
+  | VString of string
+  | VList of variant list
+  | VPair of variant * variant
+val variantize : 't ty -> 't -> variant = 
+|}];;
 
 exception VariantMismatch
+;;
 
 let rec devariantize: type t. t ty -> variant -> t =
   fun ty v ->
@@ -45,6 +61,10 @@ let rec devariantize: type t. t ty -> variant -> t =
         (devariantize ty1 x1, devariantize ty2 x2)
     | _ -> raise VariantMismatch
 ;;
+[%%expect{|
+exception VariantMismatch
+val devariantize : 't ty -> variant -> 't = 
+|}];;
 
 (* Handling records *)
 
@@ -80,6 +100,7 @@ type variant =
   | VList of variant list
   | VPair of variant * variant
   | VRecord of (string * variant) list
+;;
 
 let rec variantize: type t. t ty -> t -> variant =
   fun ty x ->
@@ -98,6 +119,24 @@ let rec variantize: type t. t ty -> t -> variant =
           (List.map (fun (Field{field_type; label; get}) ->
                        (label, variantize field_type (get x))) fields)
 ;;
+[%%expect{|
+type 'a ty =
+    Int : int ty
+  | String : string ty
+  | List : 'a ty -> 'a list ty
+  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
+  | Record : 'a record -> 'a ty
+and 'a record = { path : string; fields : 'a field_ list; }
+and 'a field_ = Field : ('a, 'b) field -> 'a field_
+and ('a, 'b) field = { label : string; field_type : 'b ty; get : 'a -> 'b; }
+type variant =
+    VInt of int
+  | VString of string
+  | VList of variant list
+  | VPair of variant * variant
+  | VRecord of (string * variant) list
+val variantize : 't ty -> 't -> variant = 
+|}];;
 
 (* Extraction *)
 
@@ -126,6 +165,7 @@ and ('a, 'builder, 'b) field_ =
    get: ('a -> 'b);
    set: ('builder -> 'b -> unit);
   }
+;;
 
 let rec devariantize: type t. t ty -> variant -> t =
   fun ty v ->
@@ -148,12 +188,36 @@ let rec devariantize: type t. t ty -> variant -> t =
         of_builder builder
     | _ -> raise VariantMismatch
 ;;
+[%%expect{|
+type 'a ty =
+    Int : int ty
+  | String : string ty
+  | List : 'a ty -> 'a list ty
+  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
+  | Record : ('a, 'builder) record -> 'a ty
+and ('a, 'builder) record = {
+  path : string;
+  fields : ('a, 'builder) field list;
+  create_builder : unit -> 'builder;
+  of_builder : 'builder -> 'a;
+}
+and ('a, 'builder) field =
+    Field : ('a, 'builder, 'b) field_ -> ('a, 'builder) field
+and ('a, 'builder, 'b) field_ = {
+  label : string;
+  field_type : 'b ty;
+  get : 'a -> 'b;
+  set : 'builder -> 'b -> unit;
+}
+val devariantize : 't ty -> variant -> 't = 
+|}];;
 
 type my_record  =
     {
      a: int;
      b: string list;
     }
+;;
 
 let my_record =
   let fields =
@@ -174,6 +238,16 @@ let my_record =
   in
   Record {path = "My_module.my_record"; fields; create_builder; of_builder}
 ;;
+[%%expect{|
+type my_record = { a : int; b : string list; }
+val my_record : my_record ty =
+  Record
+   {path = "My_module.my_record";
+    fields =
+     [Field {label = "a"; field_type = Int; get = ; set = };
+      Field {label = "b"; field_type = List String; get = ; set = }];
+    create_builder = ; of_builder = }
+|}];;
 
 (* Extension to recursive types and polymorphic variants *)
 (* by Jacques Garrigue *)
@@ -219,6 +293,7 @@ type _ ty_env =              (* type variable substitution *)
 
 (* Comparing selectors *)
 type (_,_) eq = Eq: ('a,'a) eq
+;;
 
 let rec eq_sel : type a b c. (a,b) ty_sel -> (a,c) ty_sel -> (b,c) eq option =
   fun s1 s2 ->
@@ -227,6 +302,38 @@ let rec eq_sel : type a b c. (a,b) ty_sel -> (a,c) ty_sel -> (b,c) eq option =
     | Ttl s1, Ttl s2 ->
         (match eq_sel s1 s2 with None -> None | Some Eq -> Some Eq)
     | _ -> None
+;;
+[%%expect{|
+type noarg = Noarg
+type (_, _) ty =
+    Int : (int, 'c) ty
+  | String : (string, 'd) ty
+  | List : ('a, 'e) ty -> ('a list, 'e) ty
+  | Option : ('a, 'e) ty -> ('a option, 'e) ty
+  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
+  | Var : ('a, 'a -> 'e) ty
+  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
+  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum : ('a, 'e, 'b) ty_sum -> ('a, 'e) ty
+and ('a, 'e, 'b) ty_sum = {
+  sum_proj : 'a -> string * 'e ty_dyn option;
+  sum_cases : (string * ('e, 'b) ty_case) list;
+  sum_inj : 'c. ('b, 'c) ty_sel * 'c -> 'a;
+}
+and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
+and (_, _) ty_sel =
+    Thd : ('a -> 'b, 'a) ty_sel
+  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
+and (_, _) ty_case =
+    TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case
+  | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case
+type _ ty_env =
+    Enil : unit ty_env
+  | Econs : ('a, 'e) ty * 'e ty_env -> ('a -> 'e) ty_env
+type (_, _) eq = Eq : ('a, 'a) eq
+val eq_sel : ('a, 'b) ty_sel -> ('a, 'c) ty_sel -> ('b, 'c) eq option = 
+|}];;
 
 (* Auxiliary function to get the type of a case from its selector *)
 let rec get_case : type a b e.
@@ -245,6 +352,11 @@ let rec get_case : type a b e.
       end
   | [] -> raise Not_found
 ;;
+[%%expect{|
+val get_case :
+  ('b, 'a) ty_sel ->
+  (string * ('e, 'b) ty_case) list -> string * ('a, 'e) ty option = 
+|}];;
 
 (* Untyped representation of values *)
 type variant =
@@ -255,8 +367,9 @@ type variant =
   | VPair of variant * variant
   | VConv of string * variant
   | VSum of string * variant option
+;;
 
-let may_map f = function Some x -> Some (f x) | None -> None
+let may_map f = function Some x -> Some (f x) | None -> None ;;
 
 let rec variantize : type a e. e ty_env -> (a,e) ty -> a -> variant =
   fun e ty v ->
@@ -274,6 +387,18 @@ let rec variantize : type a e. e ty_env -> (a,e) ty -> a -> variant =
       let tag, arg = ops.sum_proj v in
       VSum (tag, may_map (function Tdyn (ty,arg) -> variantize e ty arg) arg)
 ;;
+[%%expect{|
+type variant =
+    VInt of int
+  | VString of string
+  | VList of variant list
+  | VOption of variant option
+  | VPair of variant * variant
+  | VConv of string * variant
+  | VSum of string * variant option
+val may_map : ('a -> 'b) -> 'a option -> 'b option = 
+val variantize : 'e ty_env -> ('a, 'e) ty -> 'a -> variant = 
+|}];;
 
 let rec devariantize : type t e. e ty_env -> (t, e) ty -> variant -> t =
   fun e ty v ->
@@ -298,21 +423,51 @@ let rec devariantize : type t e. e ty_env -> (t, e) ty -> variant -> t =
       end
   | _ -> raise VariantMismatch
 ;;
+[%%expect{|
+val devariantize : 'e ty_env -> ('t, 'e) ty -> variant -> 't = 
+|}];;
 
 (* First attempt: represent 1-constructor variants using Conv *)
 let wrap_A t = Conv ("`A", (fun (`A x) -> x), (fun x -> `A x), t);;
+[%%expect{|
+val wrap_A : ('a, 'b) ty -> ([ `A of 'a ], 'b) ty = 
+|}];;
 
 let ty a = Rec (wrap_A (Option (Pair (a, Var)))) ;;
+[%%expect{|
+val ty : ('a, ([ `A of ('a * 'b) option ] as 'b) -> 'c) ty -> ('b, 'c) ty =
+  
+|}];;
 let v = variantize Enil (ty Int);;
+[%%expect{|
+val v : ([ `A of (int * 'a) option ] as 'a) -> variant = 
+|}];;
 let x = v (`A (Some (1, `A (Some (2, `A None))))) ;;
+[%%expect{|
+val x : variant =
+  VConv ("`A",
+   VOption
+    (Some
+      (VPair (VInt 1,
+        VConv ("`A",
+         VOption (Some (VPair (VInt 2, VConv ("`A", VOption None)))))))))
+|}];;
 
 (* Can also use it to decompose a tuple *)
 
 let triple t1 t2 t3 =
   Conv ("Triple", (fun (a,b,c) -> (a,(b,c))),
-        (fun (a,(b,c)) -> (a,b,c)), Pair (t1, Pair (t2, t3)))
+        (fun (a,(b,c)) -> (a,b,c)), Pair (t1, Pair (t2, t3)));;
+[%%expect{|
+val triple :
+  ('a, 'b) ty -> ('c, 'b) ty -> ('d, 'b) ty -> ('a * 'c * 'd, 'b) ty = 
+|}];;
 
 let v = variantize Enil (triple String Int Int) ("A", 2, 3) ;;
+[%%expect{|
+val v : variant =
+  VConv ("Triple", VPair (VString "A", VPair (VInt 2, VInt 3)))
+|}];;
 
 (* Second attempt: introduce a real sum construct *)
 let ty_abc =
@@ -333,12 +488,28 @@ let ty_abc =
         [ "A", TCarg (Thd, Int); "B", TCarg (Ttl Thd, String);
           "C", TCnoarg (Ttl (Ttl Thd)) ] }
 ;;
-
-let v = variantize Enil ty_abc (`A 3)
-let a = devariantize Enil ty_abc v
+[%%expect{|
+val ty_abc : ([ `A of int | `B of string | `C ], 'a) ty =
+  Sum
+   {sum_proj = ;
+    sum_cases =
+     [("A", TCarg (Thd, Int)); ("B", TCarg (Ttl Thd, String));
+      ("C", TCnoarg (Ttl (Ttl Thd)))];
+    sum_inj = }
+|}];;
+
+let v = variantize Enil ty_abc (`A 3);;
+[%%expect{|
+val v : variant = VSum ("A", Some (VInt 3))
+|}];;
+let a = devariantize Enil ty_abc v;;
+[%%expect{|
+val a : [ `A of int | `B of string | `C ] = `A 3
+|}];;
 
 (* And an example with recursion... *)
 type 'a vlist = [`Nil | `Cons of 'a * 'a vlist]
+;;
 
 let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t ->
   let tcons = Pair (Pop t, Var) in
@@ -354,9 +525,19 @@ let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t ->
          : (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist)
          (* One can also write the type annotation directly *)
      })
+;;
+[%%expect{|
+type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ]
+val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = 
+|}];;
 
 let v = variantize Enil (ty_list Int) (`Cons (1, `Cons (2, `Nil))) ;;
-
+[%%expect{|
+val v : variant =
+  VSum ("Cons",
+   Some
+    (VPair (VInt 1, VSum ("Cons", Some (VPair (VInt 2, VSum ("Nil", None)))))))
+|}];;
 
 (* Simpler but weaker approach *)
 
@@ -374,6 +555,7 @@ type (_,_) ty =
              -> ('a, 'e) ty
 and 'e ty_dyn =
   | Tdyn : ('a,'e) ty * 'a -> 'e ty_dyn
+;;
 
 let ty_abc : ([`A of int | `B of string | `C],'e) ty =
   (* Could also use [get_case] for proj, but direct definition is shorter *)
@@ -388,6 +570,22 @@ let ty_abc : ([`A of int | `B of string | `C],'e) ty =
     | "C", None -> `C
     | _ -> invalid_arg "ty_abc"))
 ;;
+[%%expect{|
+type (_, _) ty =
+    Int : (int, 'c) ty
+  | String : (string, 'd) ty
+  | List : ('a, 'e) ty -> ('a list, 'e) ty
+  | Option : ('a, 'e) ty -> ('a option, 'e) ty
+  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
+  | Var : ('a, 'a -> 'e) ty
+  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
+  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum : ('a -> string * 'e ty_dyn option) *
+      (string * 'e ty_dyn option -> 'a) -> ('a, 'e) ty
+and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
+val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum (, )
+|}];;
 
 (* Breaks: no way to pattern-match on a full recursive type *)
 let ty_list : type a e. (a,e) ty -> (a vlist,e) ty = fun t ->
@@ -398,6 +596,13 @@ let ty_list : type a e. (a,e) ty -> (a vlist,e) ty = fun t ->
   (function "Nil", None -> `Nil
     | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p)))
 ;;
+[%%expect{|
+Line _, characters 41-58:
+Error: This pattern matches values of type a * a vlist
+       but a pattern was expected which matches values of type
+         $Tdyn_'a = $0 * $1
+       Type a is not compatible with type $0
+|}];;
 
 (* Define Sum using object instead of record for first-class polymorphism *)
 
@@ -445,8 +650,34 @@ let ty_abc : ([`A of int | `B of string | `C] as 'a, 'e) ty =
       | Ttl Thd, v -> `B v
       | Ttl (Ttl Thd), Noarg -> `C
   end)
+;;
+[%%expect{|
+type (_, _) ty =
+    Int : (int, 'd) ty
+  | String : (string, 'f) ty
+  | List : ('a, 'e) ty -> ('a list, 'e) ty
+  | Option : ('a, 'e) ty -> ('a option, 'e) ty
+  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
+  | Var : ('a, 'a -> 'e) ty
+  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
+  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum :
+      < cases : (string * ('e, 'b) ty_case) list;
+        inj : 'c. ('b, 'c) ty_sel * 'c -> 'a;
+        proj : 'a -> string * 'e ty_dyn option > -> ('a, 'e) ty
+and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
+and (_, _) ty_sel =
+    Thd : ('a -> 'b, 'a) ty_sel
+  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
+and (_, _) ty_case =
+    TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case
+  | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case
+val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum 
+|}];;
 
 type 'a vlist = [`Nil | `Cons of 'a * 'a vlist]
+;;
 
 let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t ->
   let tcons = Pair (Pop t, Var) in
@@ -461,6 +692,10 @@ let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t ->
       | Ttl Thd, v -> `Cons v
   end))
 ;;
+[%%expect{|
+type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ]
+val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = 
+|}];;
 
 (*
 type (_,_) ty_assoc =
diff --git a/testsuite/tests/typing-gadts/dynamic_frisch.ml.principal.reference b/testsuite/tests/typing-gadts/dynamic_frisch.ml.principal.reference
deleted file mode 100644
index 894b553a..00000000
--- a/testsuite/tests/typing-gadts/dynamic_frisch.ml.principal.reference
+++ /dev/null
@@ -1,177 +0,0 @@
-
-#                       type 'a ty =
-    Int : int ty
-  | String : string ty
-  | List : 'a ty -> 'a list ty
-  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
-#                                                                     type variant =
-    VInt of int
-  | VString of string
-  | VList of variant list
-  | VPair of variant * variant
-val variantize : 't ty -> 't -> variant = 
-exception VariantMismatch
-val devariantize : 't ty -> variant -> 't = 
-#                                                   type 'a ty =
-    Int : int ty
-  | String : string ty
-  | List : 'a ty -> 'a list ty
-  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
-  | Record : 'a record -> 'a ty
-and 'a record = { path : string; fields : 'a field_ list; }
-and 'a field_ = Field : ('a, 'b) field -> 'a field_
-and ('a, 'b) field = { label : string; field_type : 'b ty; get : 'a -> 'b; }
-#                                                     type variant =
-    VInt of int
-  | VString of string
-  | VList of variant list
-  | VPair of variant * variant
-  | VRecord of (string * variant) list
-val variantize : 't ty -> 't -> variant = 
-#                                                                                                   type 'a ty =
-    Int : int ty
-  | String : string ty
-  | List : 'a ty -> 'a list ty
-  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
-  | Record : ('a, 'builder) record -> 'a ty
-and ('a, 'builder) record = {
-  path : string;
-  fields : ('a, 'builder) field list;
-  create_builder : unit -> 'builder;
-  of_builder : 'builder -> 'a;
-}
-and ('a, 'builder) field =
-    Field : ('a, 'builder, 'b) field_ -> ('a, 'builder) field
-and ('a, 'builder, 'b) field_ = {
-  label : string;
-  field_type : 'b ty;
-  get : 'a -> 'b;
-  set : 'builder -> 'b -> unit;
-}
-val devariantize : 't ty -> variant -> 't = 
-#                                                   type my_record = { a : int; b : string list; }
-val my_record : my_record ty =
-  Record
-   {path = "My_module.my_record";
-    fields =
-     [Field {label = "a"; field_type = Int; get = ; set = };
-      Field {label = "b"; field_type = List String; get = ; set = }];
-    create_builder = ; of_builder = }
-#                                                                         type noarg = Noarg
-type (_, _) ty =
-    Int : (int, 'c) ty
-  | String : (string, 'd) ty
-  | List : ('a, 'e) ty -> ('a list, 'e) ty
-  | Option : ('a, 'e) ty -> ('a option, 'e) ty
-  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
-  | Var : ('a, 'a -> 'e) ty
-  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
-  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
-  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
-  | Sum : ('a, 'e, 'b) ty_sum -> ('a, 'e) ty
-and ('a, 'e, 'b) ty_sum = {
-  sum_proj : 'a -> string * 'e ty_dyn option;
-  sum_cases : (string * ('e, 'b) ty_case) list;
-  sum_inj : 'c. ('b, 'c) ty_sel * 'c -> 'a;
-}
-and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
-and (_, _) ty_sel =
-    Thd : ('a -> 'b, 'a) ty_sel
-  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
-and (_, _) ty_case =
-    TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case
-  | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case
-#         type _ ty_env =
-    Enil : unit ty_env
-  | Econs : ('a, 'e) ty * 'e ty_env -> ('a -> 'e) ty_env
-#                                                         type (_, _) eq = Eq : ('a, 'a) eq
-val eq_sel : ('a, 'b) ty_sel -> ('a, 'c) ty_sel -> ('b, 'c) eq option = 
-val get_case :
-  ('b, 'a) ty_sel ->
-  (string * ('e, 'b) ty_case) list -> string * ('a, 'e) ty option = 
-#                                                         type variant =
-    VInt of int
-  | VString of string
-  | VList of variant list
-  | VOption of variant option
-  | VPair of variant * variant
-  | VConv of string * variant
-  | VSum of string * variant option
-val may_map : ('a -> 'b) -> 'a option -> 'b option = 
-val variantize : 'e ty_env -> ('a, 'e) ty -> 'a -> variant = 
-#                                               val devariantize : 'e ty_env -> ('t, 'e) ty -> variant -> 't = 
-#     val wrap_A : ('a, 'b) ty -> ([ `A of 'a ], 'b) ty = 
-#   val ty : ('a, ([ `A of ('a * 'b) option ] as 'b) -> 'c) ty -> ('b, 'c) ty =
-  
-# val v : ([ `A of (int * 'a) option ] as 'a) -> variant = 
-# val x : variant =
-  VConv ("`A",
-   VOption
-    (Some
-      (VPair (VInt 1,
-        VConv ("`A",
-         VOption (Some (VPair (VInt 2, VConv ("`A", VOption None)))))))))
-#               val triple :
-  ('a, 'b) ty -> ('c, 'b) ty -> ('d, 'b) ty -> ('a * 'c * 'd, 'b) ty = 
-val v : variant =
-  VConv ("Triple", VPair (VString "A", VPair (VInt 2, VInt 3)))
-#                                       val ty_abc : ([ `A of int | `B of string | `C ], 'a) ty =
-  Sum
-   {sum_proj = ;
-    sum_cases =
-     [("A", TCarg (Thd, Int)); ("B", TCarg (Ttl Thd, String));
-      ("C", TCnoarg (Ttl (Ttl Thd)))];
-    sum_inj = }
-#                                             val a : [ `A of int | `B of string | `C ] = `A 3
-type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ]
-val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = 
-val v : variant =
-  VSum ("Cons",
-   Some
-    (VPair (VInt 1, VSum ("Cons", Some (VPair (VInt 2, VSum ("Nil", None)))))))
-#                                                               type (_, _) ty =
-    Int : (int, 'c) ty
-  | String : (string, 'd) ty
-  | List : ('a, 'e) ty -> ('a list, 'e) ty
-  | Option : ('a, 'e) ty -> ('a option, 'e) ty
-  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
-  | Var : ('a, 'a -> 'e) ty
-  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
-  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
-  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
-  | Sum : ('a -> string * 'e ty_dyn option) *
-      (string * 'e ty_dyn option -> 'a) -> ('a, 'e) ty
-and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
-val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum (, )
-#                   Characters 327-344:
-      | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p)))
-                                           ^^^^^^^^^^^^^^^^^
-Error: This pattern matches values of type a * a vlist
-       but a pattern was expected which matches values of type
-         $Tdyn_'a = $0 * $1
-       Type a is not compatible with type $0 
-#                                                         type (_, _) ty =
-    Int : (int, 'd) ty
-  | String : (string, 'f) ty
-  | List : ('a, 'e) ty -> ('a list, 'e) ty
-  | Option : ('a, 'e) ty -> ('a option, 'e) ty
-  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
-  | Var : ('a, 'a -> 'e) ty
-  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
-  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
-  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
-  | Sum :
-      < cases : (string * ('e, 'b) ty_case) list;
-        inj : 'c. ('b, 'c) ty_sel * 'c -> 'a;
-        proj : 'a -> string * 'e ty_dyn option > -> ('a, 'e) ty
-and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
-and (_, _) ty_sel =
-    Thd : ('a -> 'b, 'a) ty_sel
-  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
-and (_, _) ty_case =
-    TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case
-  | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case
-#                                                                   val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum 
-type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ]
-val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = 
-#   * * * * * * * * *   
diff --git a/testsuite/tests/typing-gadts/dynamic_frisch.ml.reference b/testsuite/tests/typing-gadts/dynamic_frisch.ml.reference
deleted file mode 100644
index 894b553a..00000000
--- a/testsuite/tests/typing-gadts/dynamic_frisch.ml.reference
+++ /dev/null
@@ -1,177 +0,0 @@
-
-#                       type 'a ty =
-    Int : int ty
-  | String : string ty
-  | List : 'a ty -> 'a list ty
-  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
-#                                                                     type variant =
-    VInt of int
-  | VString of string
-  | VList of variant list
-  | VPair of variant * variant
-val variantize : 't ty -> 't -> variant = 
-exception VariantMismatch
-val devariantize : 't ty -> variant -> 't = 
-#                                                   type 'a ty =
-    Int : int ty
-  | String : string ty
-  | List : 'a ty -> 'a list ty
-  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
-  | Record : 'a record -> 'a ty
-and 'a record = { path : string; fields : 'a field_ list; }
-and 'a field_ = Field : ('a, 'b) field -> 'a field_
-and ('a, 'b) field = { label : string; field_type : 'b ty; get : 'a -> 'b; }
-#                                                     type variant =
-    VInt of int
-  | VString of string
-  | VList of variant list
-  | VPair of variant * variant
-  | VRecord of (string * variant) list
-val variantize : 't ty -> 't -> variant = 
-#                                                                                                   type 'a ty =
-    Int : int ty
-  | String : string ty
-  | List : 'a ty -> 'a list ty
-  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
-  | Record : ('a, 'builder) record -> 'a ty
-and ('a, 'builder) record = {
-  path : string;
-  fields : ('a, 'builder) field list;
-  create_builder : unit -> 'builder;
-  of_builder : 'builder -> 'a;
-}
-and ('a, 'builder) field =
-    Field : ('a, 'builder, 'b) field_ -> ('a, 'builder) field
-and ('a, 'builder, 'b) field_ = {
-  label : string;
-  field_type : 'b ty;
-  get : 'a -> 'b;
-  set : 'builder -> 'b -> unit;
-}
-val devariantize : 't ty -> variant -> 't = 
-#                                                   type my_record = { a : int; b : string list; }
-val my_record : my_record ty =
-  Record
-   {path = "My_module.my_record";
-    fields =
-     [Field {label = "a"; field_type = Int; get = ; set = };
-      Field {label = "b"; field_type = List String; get = ; set = }];
-    create_builder = ; of_builder = }
-#                                                                         type noarg = Noarg
-type (_, _) ty =
-    Int : (int, 'c) ty
-  | String : (string, 'd) ty
-  | List : ('a, 'e) ty -> ('a list, 'e) ty
-  | Option : ('a, 'e) ty -> ('a option, 'e) ty
-  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
-  | Var : ('a, 'a -> 'e) ty
-  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
-  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
-  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
-  | Sum : ('a, 'e, 'b) ty_sum -> ('a, 'e) ty
-and ('a, 'e, 'b) ty_sum = {
-  sum_proj : 'a -> string * 'e ty_dyn option;
-  sum_cases : (string * ('e, 'b) ty_case) list;
-  sum_inj : 'c. ('b, 'c) ty_sel * 'c -> 'a;
-}
-and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
-and (_, _) ty_sel =
-    Thd : ('a -> 'b, 'a) ty_sel
-  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
-and (_, _) ty_case =
-    TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case
-  | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case
-#         type _ ty_env =
-    Enil : unit ty_env
-  | Econs : ('a, 'e) ty * 'e ty_env -> ('a -> 'e) ty_env
-#                                                         type (_, _) eq = Eq : ('a, 'a) eq
-val eq_sel : ('a, 'b) ty_sel -> ('a, 'c) ty_sel -> ('b, 'c) eq option = 
-val get_case :
-  ('b, 'a) ty_sel ->
-  (string * ('e, 'b) ty_case) list -> string * ('a, 'e) ty option = 
-#                                                         type variant =
-    VInt of int
-  | VString of string
-  | VList of variant list
-  | VOption of variant option
-  | VPair of variant * variant
-  | VConv of string * variant
-  | VSum of string * variant option
-val may_map : ('a -> 'b) -> 'a option -> 'b option = 
-val variantize : 'e ty_env -> ('a, 'e) ty -> 'a -> variant = 
-#                                               val devariantize : 'e ty_env -> ('t, 'e) ty -> variant -> 't = 
-#     val wrap_A : ('a, 'b) ty -> ([ `A of 'a ], 'b) ty = 
-#   val ty : ('a, ([ `A of ('a * 'b) option ] as 'b) -> 'c) ty -> ('b, 'c) ty =
-  
-# val v : ([ `A of (int * 'a) option ] as 'a) -> variant = 
-# val x : variant =
-  VConv ("`A",
-   VOption
-    (Some
-      (VPair (VInt 1,
-        VConv ("`A",
-         VOption (Some (VPair (VInt 2, VConv ("`A", VOption None)))))))))
-#               val triple :
-  ('a, 'b) ty -> ('c, 'b) ty -> ('d, 'b) ty -> ('a * 'c * 'd, 'b) ty = 
-val v : variant =
-  VConv ("Triple", VPair (VString "A", VPair (VInt 2, VInt 3)))
-#                                       val ty_abc : ([ `A of int | `B of string | `C ], 'a) ty =
-  Sum
-   {sum_proj = ;
-    sum_cases =
-     [("A", TCarg (Thd, Int)); ("B", TCarg (Ttl Thd, String));
-      ("C", TCnoarg (Ttl (Ttl Thd)))];
-    sum_inj = }
-#                                             val a : [ `A of int | `B of string | `C ] = `A 3
-type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ]
-val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = 
-val v : variant =
-  VSum ("Cons",
-   Some
-    (VPair (VInt 1, VSum ("Cons", Some (VPair (VInt 2, VSum ("Nil", None)))))))
-#                                                               type (_, _) ty =
-    Int : (int, 'c) ty
-  | String : (string, 'd) ty
-  | List : ('a, 'e) ty -> ('a list, 'e) ty
-  | Option : ('a, 'e) ty -> ('a option, 'e) ty
-  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
-  | Var : ('a, 'a -> 'e) ty
-  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
-  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
-  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
-  | Sum : ('a -> string * 'e ty_dyn option) *
-      (string * 'e ty_dyn option -> 'a) -> ('a, 'e) ty
-and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
-val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum (, )
-#                   Characters 327-344:
-      | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p)))
-                                           ^^^^^^^^^^^^^^^^^
-Error: This pattern matches values of type a * a vlist
-       but a pattern was expected which matches values of type
-         $Tdyn_'a = $0 * $1
-       Type a is not compatible with type $0 
-#                                                         type (_, _) ty =
-    Int : (int, 'd) ty
-  | String : (string, 'f) ty
-  | List : ('a, 'e) ty -> ('a list, 'e) ty
-  | Option : ('a, 'e) ty -> ('a option, 'e) ty
-  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
-  | Var : ('a, 'a -> 'e) ty
-  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
-  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
-  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
-  | Sum :
-      < cases : (string * ('e, 'b) ty_case) list;
-        inj : 'c. ('b, 'c) ty_sel * 'c -> 'a;
-        proj : 'a -> string * 'e ty_dyn option > -> ('a, 'e) ty
-and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
-and (_, _) ty_sel =
-    Thd : ('a -> 'b, 'a) ty_sel
-  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
-and (_, _) ty_case =
-    TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case
-  | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case
-#                                                                   val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum 
-type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ]
-val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = 
-#   * * * * * * * * *   
diff --git a/testsuite/tests/typing-gadts/nested_equations.ml b/testsuite/tests/typing-gadts/nested_equations.ml
new file mode 100644
index 00000000..4039e358
--- /dev/null
+++ b/testsuite/tests/typing-gadts/nested_equations.ml
@@ -0,0 +1,84 @@
+(* Tests for nested equations (bind abstract types from other modules) *)
+
+type _ t = Int : int t;;
+
+let to_int (type a) (w : a t) (x : a) : int = let Int = w in x;;
+[%%expect{|
+type _ t = Int : int t
+val to_int : 'a t -> 'a -> int = 
+|}];;
+
+let w_bool : bool t = Obj.magic 0;;
+let f_bool (x : bool) : int = let Int = w_bool in x;; (* fail *)
+[%%expect{|
+val w_bool : bool t = Int
+Line _, characters 34-37:
+Error: This pattern matches values of type int t
+       but a pattern was expected which matches values of type bool t
+       Type int is not compatible with type bool
+|}];;
+
+let w_buffer : Buffer.t t = Obj.magic 0;;
+let f_buffer (x : Buffer.t) : int = let Int = w_buffer in x;; (* ok *)
+[%%expect{|
+val w_buffer : Buffer.t t = Int
+val f_buffer : Buffer.t -> int = 
+|}];;
+
+let w_spec : Arg.spec t = Obj.magic 0;;
+let f_spec (x : Arg.spec) : int = let Int = w_spec in x;; (* fail *)
+[%%expect{|
+val w_spec : Arg.spec t = Int
+Line _, characters 38-41:
+Error: This pattern matches values of type int t
+       but a pattern was expected which matches values of type Arg.spec t
+       Type int is not compatible with type Arg.spec
+|}];;
+
+module M : sig type u val w : u t val x : u end =
+  struct type u = int let w = Int let x = 33 end;;
+let m_x : int = let Int = M.w in M.x;;
+[%%expect{|
+module M : sig type u val w : u t val x : u end
+val m_x : int = 33
+|}];;
+
+module F (X : sig type u = int val x : u end) = struct let x : int = X.x end;;
+let fm_x : int = let Int = M.w in let module FM = F(M) in FM.x;; (* ok *)
+[%%expect{|
+module F :
+  functor (X : sig type u = int val x : u end) -> sig val x : int end
+val fm_x : int = 33
+|}];;
+
+module M' = struct module M : sig type u val w : u t val x : u end = M end;;
+module F' (X : sig module M : sig type u = int val x : u end end) =
+  struct let x : int = X.M.x end;;
+let fm'_x : int =
+  let Int = M'.M.w in let module FM' = F'(M') in FM'.x;; (* ok *)
+[%%expect{|
+module M' : sig module M : sig type u val w : u t val x : u end end
+module F' :
+  functor (X : sig module M : sig type u = int val x : u end end) ->
+    sig val x : int end
+val fm'_x : int = 33
+|}];;
+
+(* PR#7233 *)
+
+type (_, _) eq = Refl : ('a, 'a) eq
+
+module type S = sig
+  type t
+  val eql : (t, int) eq
+end
+
+module F (M : S) = struct
+  let zero : M.t =
+    let Refl = M.eql in 0
+end;;
+[%%expect{|
+type (_, _) eq = Refl : ('a, 'a) eq
+module type S = sig type t val eql : (t, int) eq end
+module F : functor (M : S) -> sig val zero : M.t end
+|}];;
diff --git a/testsuite/tests/typing-gadts/omega07.ml b/testsuite/tests/typing-gadts/omega07.ml
index ddd7133c..6c729abe 100644
--- a/testsuite/tests/typing-gadts/omega07.ml
+++ b/testsuite/tests/typing-gadts/omega07.ml
@@ -24,6 +24,16 @@ type (_,_) seq =
 ;;
 
 let l1 = Scons (3, Scons (5, Snil)) ;;
+[%%expect{|
+type ('a, 'b) sum = Inl of 'a | Inr of 'b
+type zero = Zero
+type 'a succ = Succ of 'a
+type _ nat = NZ : zero nat | NS : 'a nat -> 'a succ nat
+type (_, _) seq =
+    Snil : ('a, zero) seq
+  | Scons : 'a * ('a, 'n) seq -> ('a, 'n succ) seq
+val l1 : (int, zero succ succ) seq = Scons (3, Scons (5, Snil))
+|}];;
 
 (* We do not have type level functions, so we need to use witnesses. *)
 (* We copy here the definitions from section 3.9 *)
@@ -38,6 +48,12 @@ let rec length : type a n. (a,n) seq -> n nat = function
   | Snil -> NZ
   | Scons (_, s) -> NS (length s)
 ;;
+[%%expect{|
+type (_, _, _) plus =
+    PlusZ : 'a nat -> (zero, 'a, 'a) plus
+  | PlusS : ('a, 'b, 'c) plus -> ('a succ, 'b, 'c succ) plus
+val length : ('a, 'n) seq -> 'n nat = 
+|}];;
 
 (* app returns the catenated lists with a witness proving that
    the size is the sum of its two inputs *)
@@ -51,6 +67,11 @@ let rec app : type a n m. (a,n) seq -> (a,m) seq -> (a,n,m) app =
       let App (xs'', pl) = app xs' ys in
       App (Scons (x, xs''), PlusS pl)
 ;;
+[%%expect{|
+type (_, _, _) app =
+    App : ('a, 'p) seq * ('n, 'm, 'p) plus -> ('a, 'n, 'm) app
+val app : ('a, 'n) seq -> ('a, 'm) seq -> ('a, 'n, 'm) app = 
+|}];;
 
 (* 3.1 Feature: kinds *)
 
@@ -86,6 +107,29 @@ type (_,_) tree =
 ;;
 let tree1 = Tfork (Tfork (Ttip, Tnode 4), Tfork (Tnode 4, Tnode 3))
 ;;
+[%%expect{|
+type tp = TP
+type nd = ND
+type ('a, 'b) fk = FK
+type _ shape =
+    Tp : tp shape
+  | Nd : nd shape
+  | Fk : 'a shape * 'b shape -> ('a, 'b) fk shape
+type tt = TT
+type ff = FF
+type _ boolean = BT : tt boolean | BF : ff boolean
+type (_, _) path =
+    Pnone : 'a -> (tp, 'a) path
+  | Phere : (nd, 'a) path
+  | Pleft : ('x, 'a) path -> (('x, 'y) fk, 'a) path
+  | Pright : ('y, 'a) path -> (('x, 'y) fk, 'a) path
+type (_, _) tree =
+    Ttip : (tp, 'a) tree
+  | Tnode : 'a -> (nd, 'a) tree
+  | Tfork : ('x, 'a) tree * ('y, 'a) tree -> (('x, 'y) fk, 'a) tree
+val tree1 : (((tp, nd) fk, (nd, nd) fk) fk, int) tree =
+  Tfork (Tfork (Ttip, Tnode 4), Tfork (Tnode 4, Tnode 3))
+|}];;
 let rec find : type sh.
     ('a -> 'a -> bool) -> 'a -> (sh,'a) tree -> (sh,'a) path list
   = fun eq n t ->
@@ -97,6 +141,10 @@ let rec find : type sh.
         List.map (fun x -> Pleft x) (find eq n x) @
         List.map (fun x -> Pright x) (find eq n y)
 ;;
+[%%expect{|
+val find : ('a -> 'a -> bool) -> 'a -> ('sh, 'a) tree -> ('sh, 'a) path list =
+  
+|}];;
 let rec extract : type sh. (sh,'a) path -> (sh,'a) tree -> 'a = fun p t ->
   match (p, t) with
   | Pnone x, Ttip -> x
@@ -104,6 +152,9 @@ let rec extract : type sh. (sh,'a) path -> (sh,'a) tree -> 'a = fun p t ->
   | Pleft p, Tfork(l,_) -> extract p l
   | Pright p, Tfork(_,r) -> extract p r
 ;;
+[%%expect{|
+val extract : ('sh, 'a) path -> ('sh, 'a) tree -> 'a = 
+|}];;
 
 (* 3.4 Pattern : Witness *)
 
@@ -126,17 +177,38 @@ let even4 : four even = EvenSS (EvenSS EvenZ)
 ;;
 let p1 : (two, one, three) plus = PlusS (PlusS (PlusZ (NS NZ)))
 ;;
+[%%expect{|
+type (_, _) le =
+    LeZ : 'a nat -> (zero, 'a) le
+  | LeS : ('n, 'm) le -> ('n succ, 'm succ) le
+type _ even = EvenZ : zero even | EvenSS : 'n even -> 'n succ succ even
+type one = zero succ
+type two = one succ
+type three = two succ
+type four = three succ
+val even0 : zero even = EvenZ
+val even2 : two even = EvenSS EvenZ
+val even4 : four even = EvenSS (EvenSS EvenZ)
+val p1 : (two, one, three) plus = PlusS (PlusS (PlusZ (NS NZ)))
+|}];;
 let rec summandLessThanSum : type a b c. (a,b,c) plus -> (a,c) le = fun p ->
   match p with
   | PlusZ n -> LeZ n
   | PlusS p' -> LeS (summandLessThanSum p')
 ;;
+[%%expect{|
+val summandLessThanSum : ('a, 'b, 'c) plus -> ('a, 'c) le = 
+|}];;
 
 (* 3.8 Pattern: Leibniz Equality *)
 
 type (_,_) equal = Eq : ('a,'a) equal
 
 let convert : type a b. (a,b) equal -> a -> b = fun Eq x -> x
+[%%expect{|
+type (_, _) equal = Eq : ('a, 'a) equal
+val convert : ('a, 'b) equal -> 'a -> 'b = 
+|}];;
 
 let rec sameNat : type a b. a nat -> b nat -> (a,b) equal option = fun a b ->
   match a, b with
@@ -148,6 +220,9 @@ let rec sameNat : type a b. a nat -> b nat -> (a,b) equal option = fun a b ->
       end
   | _ -> None
 ;;
+[%%expect{|
+val sameNat : 'a nat -> 'b nat -> ('a, 'b) equal option = 
+|}];;
 
 (* Extra: associativity of addition *)
 
@@ -158,6 +233,11 @@ let rec plus_func : type a b m n.
   | PlusZ _, PlusZ _ -> Eq
   | PlusS p1', PlusS p2' ->
       let Eq = plus_func p1' p2' in Eq
+;;
+[%%expect{|
+val plus_func : ('a, 'b, 'm) plus -> ('a, 'b, 'n) plus -> ('m, 'n) equal =
+  
+|}];;
 
 let rec plus_assoc : type a b c ab bc m n.
   (a,b,ab) plus -> (ab,c,m) plus ->
@@ -169,6 +249,12 @@ let rec plus_assoc : type a b c ab bc m n.
       let PlusS p2' = p2 in
       let Eq = plus_assoc p1' p2' p3 p4' in Eq
 ;;
+[%%expect{|
+val plus_assoc :
+  ('a, 'b, 'ab) plus ->
+  ('ab, 'c, 'm) plus ->
+  ('b, 'c, 'bc) plus -> ('a, 'bc, 'n) plus -> ('m, 'n) equal = 
+|}];;
 
 (* 3.9 Computing Programs and Properties Simultaneously *)
 
@@ -176,6 +262,9 @@ let rec plus_assoc : type a b c ab bc m n.
 
 let smaller : type a b. (a succ, b succ) le -> (a,b) le =
   function LeS x -> x ;;
+[%%expect{|
+val smaller : ('a succ, 'b succ) le -> ('a, 'b) le = 
+|}];;
 
 type (_,_) diff = Diff : 'c nat * ('a,'c,'b) plus -> ('a,'b) diff ;;
 
@@ -197,6 +286,10 @@ let rec diff : type a b. (a,b) le -> a nat -> b nat -> (a,b) diff =
   | LeS q, NS x, NS y ->
       match diff q x y with Diff (m, p) -> Diff (m, PlusS p)
 ;;
+[%%expect{|
+type (_, _) diff = Diff : 'c nat * ('a, 'c, 'b) plus -> ('a, 'b) diff
+val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = 
+|}];;
 
 let rec diff : type a b. (a,b) le -> a nat -> b nat -> (a,b) diff =
   fun le a b ->
@@ -206,6 +299,9 @@ let rec diff : type a b. (a,b) le -> a nat -> b nat -> (a,b) diff =
       (match diff q x y with Diff (m, p) -> Diff (m, PlusS p))
   | _ -> .
 ;;
+[%%expect{|
+val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = 
+|}];;
 
 let rec diff : type a b. (a,b) le -> b nat -> (a,b) diff =
   fun le b ->
@@ -214,6 +310,9 @@ let rec diff : type a b. (a,b) le -> b nat -> (a,b) diff =
   | NS y, LeS q ->
       match diff q y with Diff (m, p) -> Diff (m, PlusS p)
 ;;
+[%%expect{|
+val diff : ('a, 'b) le -> 'b nat -> ('a, 'b) diff = 
+|}];;
 
 type (_,_) filter = Filter : ('m,'n) le * ('a,'m) seq -> ('a,'n) filter
 
@@ -221,6 +320,10 @@ let rec leS' : type m n. (m,n) le -> (m,n succ) le = function
   | LeZ n -> LeZ (NS n)
   | LeS le -> LeS (leS' le)
 ;;
+[%%expect{|
+type (_, _) filter = Filter : ('m, 'n) le * ('a, 'm) seq -> ('a, 'n) filter
+val leS' : ('m, 'n) le -> ('m, 'n succ) le = 
+|}];;
 
 let rec filter : type a n. (a -> bool) -> (a,n) seq -> (a,n) filter =
   fun f s ->
@@ -231,6 +334,9 @@ let rec filter : type a n. (a -> bool) -> (a,n) seq -> (a,n) filter =
         if f a then Filter (LeS le, Scons (a, l'))
         else Filter (leS' le, l')
 ;;
+[%%expect{|
+val filter : ('a -> bool) -> ('a, 'n) seq -> ('a, 'n) filter = 
+|}];;
 
 (* 4.1 AVL trees *)
 
@@ -247,7 +353,19 @@ type _ avl =
 type avl' = Avl : 'h avl -> avl'
 ;;
 
-let empty = Avl Leaf
+let empty = Avl Leaf;;
+[%%expect{|
+type (_, _, _) balance =
+    Less : ('h, 'h succ, 'h succ) balance
+  | Same : ('h, 'h, 'h) balance
+  | More : ('h succ, 'h, 'h succ) balance
+type _ avl =
+    Leaf : zero avl
+  | Node : ('hL, 'hR, 'hMax) balance * 'hL avl * int *
+      'hR avl -> 'hMax succ avl
+type avl' = Avl : 'h avl -> avl'
+val empty : avl' = Avl Leaf
+|}];;
 
 let rec elem : type h. int -> h avl -> bool = fun x t ->
   match t with
@@ -255,6 +373,9 @@ let rec elem : type h. int -> h avl -> bool = fun x t ->
   | Node (_, l, y, r) ->
       x = y || if x < y then elem x l else elem x r
 ;;
+[%%expect{|
+val elem : int -> 'h avl -> bool = 
+|}];;
 
 let rec rotr : type n. (n succ succ) avl -> int -> n avl ->
   ((n succ succ) avl, (n succ succ succ) avl) sum =
@@ -269,6 +390,11 @@ let rec rotr : type n. (n succ succ) avl -> int -> n avl ->
   | Node (Less, a, x, Node (More, b, z, c)) ->
       Inl (Node (Same, Node (Same, a, x, b), z, Node (Less, c, y, tR)))
 ;;
+[%%expect{|
+val rotr :
+  'n succ succ avl ->
+  int -> 'n avl -> ('n succ succ avl, 'n succ succ succ avl) sum = 
+|}];;
 let rec rotl : type n. n avl -> int -> (n succ succ) avl ->
   ((n succ succ) avl, (n succ succ succ) avl) sum =
   fun tL u tR ->
@@ -282,6 +408,12 @@ let rec rotl : type n. n avl -> int -> (n succ succ) avl ->
   | Node (More, Node (More, a, x, b), y, c) ->
       Inl (Node (Same, Node (Same, tL, u, a), x, Node (Less, b, y, c)))
 ;;
+[%%expect{|
+val rotl :
+  'n avl ->
+  int -> 'n succ succ avl -> ('n succ succ avl, 'n succ succ succ avl) sum =
+  
+|}];;
 let rec ins : type n. int -> n avl -> (n avl, (n succ) avl) sum =
   fun x t ->
   match t with
@@ -306,12 +438,18 @@ let rec ins : type n. int -> n avl -> (n avl, (n succ) avl) sum =
             | Less -> rotl a y b
       end
 ;;
+[%%expect{|
+val ins : int -> 'n avl -> ('n avl, 'n succ avl) sum = 
+|}];;
 
 let insert x (Avl t) =
   match ins x t with
   | Inl t -> Avl t
   | Inr t -> Avl t
 ;;
+[%%expect{|
+val insert : int -> avl' -> avl' = 
+|}];;
 
 let rec del_min : type n. (n succ) avl -> int * (n avl, (n succ) avl) sum =
   function
@@ -325,6 +463,10 @@ let rec del_min : type n. (n succ) avl -> int * (n avl, (n succ) avl) sum =
           | Same -> Inr (Node (Less, l, x, r))
           | More -> Inl (Node (Same, l, x, r))
           | Less -> rotl l x r)
+;;
+[%%expect{|
+val del_min : 'n succ avl -> int * ('n avl, 'n succ avl) sum = 
+|}];;
 
 type _ avl_del =
   | Dsame : 'n avl -> 'n avl_del
@@ -377,12 +519,21 @@ let rec del : type n. int -> n avl -> n avl_del = fun y t ->
             end
       end
 ;;
+[%%expect{|
+type _ avl_del =
+    Dsame : 'n avl -> 'n avl_del
+  | Ddecr : ('m succ, 'n) equal * 'm avl -> 'n avl_del
+val del : int -> 'n avl -> 'n avl_del = 
+|}];;
 
 let delete x (Avl t) =
   match del x t with
   | Dsame t -> Avl t
   | Ddecr (_, t) -> Avl t
 ;;
+[%%expect{|
+val delete : int -> avl' -> avl' = 
+|}];;
 
 
 (* Exercise 22: Red-black trees *)
@@ -409,6 +560,26 @@ type (_,_) ctxt =
 
 let blacken = function
     Rnode (l, e, r) -> Bnode (l, e, r)
+;;
+[%%expect{|
+type red = RED
+type black = BLACK
+type (_, _) sub_tree =
+    Bleaf : (black, zero) sub_tree
+  | Rnode : (black, 'n) sub_tree * int *
+      (black, 'n) sub_tree -> (red, 'n) sub_tree
+  | Bnode : ('cL, 'n) sub_tree * int *
+      ('cR, 'n) sub_tree -> (black, 'n succ) sub_tree
+type rb_tree = Root : (black, 'n) sub_tree -> rb_tree
+type dir = LeftD | RightD
+type (_, _) ctxt =
+    CNil : (black, 'n) ctxt
+  | CRed : int * dir * (black, 'n) sub_tree *
+      (red, 'n) ctxt -> (black, 'n) ctxt
+  | CBlk : int * dir * ('c1, 'n) sub_tree *
+      (black, 'n succ) ctxt -> ('c, 'n) ctxt
+val blacken : (red, 'a) sub_tree -> (black, 'a succ) sub_tree = 
+|}];;
 
 type _ crep =
   | Red : red crep
@@ -419,6 +590,10 @@ let color : type c n. (c,n) sub_tree -> c crep = function
   | Rnode _ -> Red
   | Bnode _ -> Black
 ;;
+[%%expect{|
+type _ crep = Red : red crep | Black : black crep
+val color : ('c, 'n) sub_tree -> 'c crep = 
+|}];;
 
 let rec fill : type c n. (c,n) ctxt -> (c,n) sub_tree -> rb_tree =
   fun ct t ->
@@ -429,6 +604,9 @@ let rec fill : type c n. (c,n) ctxt -> (c,n) sub_tree -> rb_tree =
   | CBlk (e, LeftD, uncle, c) -> fill c (Bnode (uncle, e, t))
   | CBlk (e, RightD, uncle, c) -> fill c (Bnode (t, e, uncle))
 ;;
+[%%expect{|
+val fill : ('c, 'n) ctxt -> ('c, 'n) sub_tree -> rb_tree = 
+|}];;
 let recolor d1 pE sib d2 gE uncle t =
   match d1, d2 with
   | LeftD, RightD -> Rnode (Bnode (sib, pE, t), gE, uncle)
@@ -436,6 +614,16 @@ let recolor d1 pE sib d2 gE uncle t =
   | LeftD, LeftD -> Rnode (uncle, gE, Bnode (sib, pE, t))
   | RightD, LeftD -> Rnode (uncle, gE, Bnode (t, pE, sib))
 ;;
+[%%expect{|
+val recolor :
+  dir ->
+  int ->
+  ('a, 'b) sub_tree ->
+  dir ->
+  int ->
+  (black, 'b succ) sub_tree -> ('c, 'b) sub_tree -> (red, 'b succ) sub_tree =
+  
+|}];;
 let rotate d1 pE sib d2 gE uncle (Rnode (x, e, y)) =
   match d1, d2 with
   | RightD, RightD -> Bnode (Rnode (x,e,y), pE, Rnode (sib, gE, uncle))
@@ -443,6 +631,16 @@ let rotate d1 pE sib d2 gE uncle (Rnode (x, e, y)) =
   | LeftD,  LeftD  -> Bnode (Rnode (uncle, gE, sib), pE, Rnode (x,e,y))
   | RightD, LeftD  -> Bnode (Rnode (uncle, gE, x), e, Rnode (y, pE, sib))
 ;;
+[%%expect{|
+val rotate :
+  dir ->
+  int ->
+  (black, 'a) sub_tree ->
+  dir ->
+  int ->
+  (black, 'a) sub_tree -> (red, 'a) sub_tree -> (black, 'a succ) sub_tree =
+  
+|}];;
 let rec repair : type c n. (red,n) sub_tree -> (c,n) ctxt -> rb_tree =
   fun t ct ->
   match ct with
@@ -454,6 +652,9 @@ let rec repair : type c n. (red,n) sub_tree -> (c,n) ctxt -> rb_tree =
       | Red -> repair (recolor dir e sib dir' e' (blacken uncle) t) ct
       | Black -> fill ct (rotate dir e sib dir' e' uncle t)
 ;;
+[%%expect{|
+val repair : (red, 'n) sub_tree -> ('c, 'n) ctxt -> rb_tree = 
+|}];;
 let rec ins : type c n. int -> (c,n) sub_tree -> (c,n) ctxt -> rb_tree =
   fun e t ct ->
   match t with
@@ -465,8 +666,14 @@ let rec ins : type c n. int -> (c,n) sub_tree -> (c,n) ctxt -> rb_tree =
                 else ins e r (CBlk (e', LeftD, l, ct))
   | Bleaf -> repair (Rnode (Bleaf, e, Bleaf)) ct
 ;;
+[%%expect{|
+val ins : int -> ('c, 'n) sub_tree -> ('c, 'n) ctxt -> rb_tree = 
+|}];;
 let insert e (Root t) = ins e t CNil
 ;;
+[%%expect{|
+val insert : int -> rb_tree -> rb_tree = 
+|}];;
 
 (* 5.7 typed object languages using GADTs *)
 
@@ -479,6 +686,18 @@ type _ term =
 
 let ex1 = Ap (Add, Pair (Const 3, Const 5))
 let ex2 = Pair (ex1, Const 1)
+;;
+[%%expect{|
+type _ term =
+    Const : int -> int term
+  | Add : (int * int -> int) term
+  | LT : (int * int -> bool) term
+  | Ap : ('a -> 'b) term * 'a term -> 'b term
+  | Pair : 'a term * 'b term -> ('a * 'b) term
+val ex1 : int term = Ap (Add, Pair (Const 3, Const 5))
+val ex2 : (int * int) term =
+  Pair (Ap (Add, Pair (Const 3, Const 5)), Const 1)
+|}];;
 
 let rec eval_term : type a. a term -> a = function
   | Const x -> x
@@ -486,6 +705,10 @@ let rec eval_term : type a. a term -> a = function
   | LT  -> fun (x,y) -> x eval_term f (eval_term x)
   | Pair(x,y) -> (eval_term x, eval_term y)
+;;
+[%%expect{|
+val eval_term : 'a term -> 'a = 
+|}];;
 
 type _ rep =
   | Rint  : int rep
@@ -516,6 +739,15 @@ let rec rep_equal : type a b. a rep -> b rep -> (a, b) equal option =
       end
   | _ -> None
 ;;
+[%%expect{|
+type _ rep =
+    Rint : int rep
+  | Rbool : bool rep
+  | Rpair : 'a rep * 'b rep -> ('a * 'b) rep
+  | Rfun : 'a rep * 'b rep -> ('a -> 'b) rep
+type (_, _) equal = Eq : ('a, 'a) equal
+val rep_equal : 'a rep -> 'b rep -> ('a, 'b) equal option = 
+|}];;
 
 type assoc = Assoc : string * 'a rep * 'a -> assoc
 
@@ -528,6 +760,11 @@ let rec assoc : type a. string -> a rep -> assoc list -> a =
         | None -> failwith ("Wrong type for " ^ x)
         | Some Eq -> v
       else assoc x r env
+;;
+[%%expect{|
+type assoc = Assoc : string * 'a rep * 'a -> assoc
+val assoc : string -> 'a rep -> assoc list -> 'a = 
+|}];;
 
 type _ term =
   | Var   : string * 'a rep -> 'a term
@@ -548,12 +785,31 @@ let rec eval_term : type a. assoc list -> a term -> a =
   | Ap(f,x) -> eval_term env f (eval_term env x)
   | Pair(x,y) -> (eval_term env x, eval_term env y)
 ;;
+[%%expect{|
+type _ term =
+    Var : string * 'a rep -> 'a term
+  | Abs : string * 'a rep * 'b term -> ('a -> 'b) term
+  | Const : int -> int term
+  | Add : (int * int -> int) term
+  | LT : (int * int -> bool) term
+  | Ap : ('a -> 'b) term * 'a term -> 'b term
+  | Pair : 'a term * 'b term -> ('a * 'b) term
+val eval_term : assoc list -> 'a term -> 'a = 
+|}];;
 
 let ex3 = Abs ("x", Rint, Ap (Add, Pair (Var("x",Rint), Var("x",Rint))))
 let ex4 = Ap (ex3, Const 3)
 
 let v4 = eval_term [] ex4
 ;;
+[%%expect{|
+val ex3 : (int -> int) term =
+  Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint))))
+val ex4 : int term =
+  Ap (Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint)))),
+   Const 3)
+val v4 : int = 6
+|}];;
 
 (* 5.9/5.10 Language with binding *)
 
@@ -577,6 +833,25 @@ type y = Y
 let ex1 = App (Var X, Shift (Var Y))
 let ex2 = Abs (X, Abs (Y, App (Shift (Var X), Var Y)))
 ;;
+[%%expect{|
+type rnil = RNIL
+type ('a, 'b, 'c) rcons = RCons of 'a * 'b * 'c
+type _ is_row =
+    Rnil : rnil is_row
+  | Rcons : 'c is_row -> ('a, 'b, 'c) rcons is_row
+type (_, _) lam =
+    Const : int -> ('e, int) lam
+  | Var : 'a -> (('a, 't, 'e) rcons, 't) lam
+  | Shift : ('e, 't) lam -> (('a, 'q, 'e) rcons, 't) lam
+  | Abs : 'a * (('a, 's, 'e) rcons, 't) lam -> ('e, 's -> 't) lam
+  | App : ('e, 's -> 't) lam * ('e, 's) lam -> ('e, 't) lam
+type x = X
+type y = Y
+val ex1 : ((x, 'a -> 'b, (y, 'a, 'c) rcons) rcons, 'b) lam =
+  App (Var X, Shift (Var Y))
+val ex2 : ('a, ('b -> 'c) -> 'b -> 'c) lam =
+  Abs (, Abs (, App (Shift (Var ), Var )))
+|}];;
 
 type _ env =
   | Enil : rnil env
@@ -591,6 +866,12 @@ let rec eval_lam : type e t. e env -> (e, t) lam -> t =
   | _, Abs (n, body) -> fun x -> eval_lam (Econs (n, x, env)) body
   | _, App (f, x)    -> eval_lam env f (eval_lam env x)
 ;;
+[%%expect{|
+type _ env =
+    Enil : rnil env
+  | Econs : 'a * 't * 'e env -> ('a, 't, 'e) rcons env
+val eval_lam : 'e env -> ('e, 't) lam -> 't = 
+|}];;
 
 type add = Add
 type suc = Suc
@@ -607,9 +888,49 @@ let add = Shift (Shift (Var Add : (_, int -> int -> int) lam))
 let double = Abs (X, App (App (Shift add, Var X), Var X))
 let ex3 = App (double, _3)
 ;;
+[%%expect{|
+type add = Add
+type suc = Suc
+val env0 :
+  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
+  rcons env = Econs (Zero, 0, Econs (Suc, , Econs (Add, , Enil)))
+val _0 : ((zero, int, 'a) rcons, int) lam = Var Zero
+val suc :
+  (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam ->
+  (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam = 
+val _1 : ((zero, int, (suc, int -> int, '_a) rcons) rcons, int) lam =
+  App (Shift (Var Suc), Var Zero)
+val _2 : ((zero, int, (suc, int -> int, '_a) rcons) rcons, int) lam =
+  App (Shift (Var Suc), App (Shift (Var Suc), Var Zero))
+val _3 : ((zero, int, (suc, int -> int, '_a) rcons) rcons, int) lam =
+  App (Shift (Var Suc),
+   App (Shift (Var Suc), App (Shift (Var Suc), Var Zero)))
+val add :
+  (('a, 'b, ('c, 'd, (add, int -> int -> int, 'e) rcons) rcons) rcons,
+   int -> int -> int)
+  lam = Shift (Shift (Var Add))
+val double :
+  (('a, 'b, ('c, 'd, (add, int -> int -> int, 'e) rcons) rcons) rcons,
+   int -> int)
+  lam =
+  Abs (,
+   App (App (Shift (Shift (Shift (Var Add))), Var ), Var ))
+val ex3 :
+  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
+   rcons, int)
+  lam =
+  App
+   (Abs (,
+     App (App (Shift (Shift (Shift (Var Add))), Var ), Var )),
+   App (Shift (Var Suc),
+    App (Shift (Var Suc), App (Shift (Var Suc), Var Zero))))
+|}];;
 
 let v3 = eval_lam env0 ex3
 ;;
+[%%expect{|
+val v3 : int = 6
+|}];;
 
 (* 5.13: Constructing typing derivations at runtime *)
 
@@ -634,6 +955,10 @@ let rec compare : type a b. a rep -> b rep -> (string, (a,b) equal) sum =
   | I, Ar _ -> Inl "I <> Ar _"
   | Ar _, I -> Inl "Ar _ <> I"
 ;;
+[%%expect{|
+type _ rep = I : int rep | Ar : 'a rep * 'b rep -> ('a -> 'b) rep
+val compare : 'a rep -> 'b rep -> (string, ('a, 'b) equal) sum = 
+|}];;
 
 type term =
   | C of int
@@ -660,6 +985,18 @@ let rec lookup : type e. string -> e ctx -> e checked =
       | Cerror m -> Cerror m
       | Cok (v, t) -> Cok (Shift v, t)
 ;;
+[%%expect{|
+type term =
+    C of int
+  | Ab : string * 'a rep * term -> term
+  | Ap of term * term
+  | V of string
+type _ ctx =
+    Cnil : rnil ctx
+  | Ccons : 't * string * 'x rep * 'e ctx -> ('t, 'x, 'e) rcons ctx
+type _ checked = Cerror of string | Cok : ('e, 't) lam * 't rep -> 'e checked
+val lookup : string -> 'e ctx -> 'e checked = 
+|}];;
 
 let rec tc : type n e. n nat -> e ctx -> term -> e checked =
   fun n ctx t ->
@@ -686,6 +1023,9 @@ let rec tc : type n e. n nat -> e ctx -> term -> e checked =
       end
   | C m -> Cok (Const m, I)
 ;;
+[%%expect{|
+val tc : 'n nat -> 'e ctx -> term -> 'e checked = 
+|}];;
 
 let ctx0 =
   Ccons (Zero, "0", I,
@@ -696,14 +1036,45 @@ let ex1 = Ab ("x", I, Ap(Ap(V"+",V"x"),V"x"));;
 let c1 = tc NZ ctx0 ex1;;
 let ex2 = Ap (ex1, C 3);;
 let c2 = tc NZ ctx0 ex2;;
+[%%expect{|
+val ctx0 :
+  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
+  rcons ctx =
+  Ccons (Zero, "0", I,
+   Ccons (Suc, "S", Ar (I, I), Ccons (Add, "+", Ar (I, Ar (I, I)), Cnil)))
+val ex1 : term = Ab ("x", I, Ap (Ap (V "+", V "x"), V "x"))
+val c1 :
+  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
+  rcons checked =
+  Cok
+   (Abs (,
+     App (App (Shift (Shift (Shift (Var Add))), Var ), Var )),
+   Ar (I, I))
+val ex2 : term = Ap (Ab ("x", I, Ap (Ap (V "+", V "x"), V "x")), C 3)
+val c2 :
+  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
+  rcons checked =
+  Cok
+   (App
+     (Abs (,
+       App (App (Shift (Shift (Shift (Var Add))), Var ), Var )),
+     Const 3),
+   I)
+|}];;
 
 let eval_checked env = function
   | Cerror s -> failwith s
   | Cok (e, I) -> (eval_lam env e : int)
   | Cok _ -> failwith "Can only evaluate expressions of type I"
 ;;
+[%%expect{|
+val eval_checked : 'a env -> 'a checked -> int = 
+|}];;
 
 let v2 = eval_checked env0 c2 ;;
+[%%expect{|
+val v2 : int = 6
+|}];;
 
 (* 5.12 Soundness *)
 
@@ -729,6 +1100,26 @@ type (_,_,_) lam =
 ;;
 
 let ex1 = App (Lam (X, Var X), Const (IntR, 3))
+[%%expect{|
+type pexp = PEXP
+type pval = PVAL
+type _ mode = Pexp : pexp mode | Pval : pval mode
+type ('a, 'b) tarr = TARR
+type tint = TINT
+type (_, _) rel =
+    IntR : (tint, int) rel
+  | IntTo : ('b, 's) rel -> ((tint, 'b) tarr, int -> 's) rel
+type (_, _, _) lam =
+    Const : ('a, 'b) rel * 'b -> (pval, 'env, 'a) lam
+  | Var : 'a -> (pval, ('a, 't, 'e) rcons, 't) lam
+  | Shift : ('m, 'e, 't) lam -> ('m, ('a, 'q, 'e) rcons, 't) lam
+  | Lam : 'a *
+      ('m, ('a, 's, 'e) rcons, 't) lam -> (pval, 'e, ('s, 't) tarr) lam
+  | App : ('m1, 'e, ('s, 't) tarr) lam *
+      ('m2, 'e, 's) lam -> (pexp, 'e, 't) lam
+val ex1 : (pexp, 'a, tint) lam =
+  App (Lam (, Var ), Const (IntR, ))
+|}];;
 
 let rec mode : type m e t. (m,e,t) lam -> m mode = function
   | Lam (v, body) -> Pval
@@ -737,6 +1128,9 @@ let rec mode : type m e t. (m,e,t) lam -> m mode = function
   | Shift e -> mode e
   | App _ -> Pexp
 ;;
+[%%expect{|
+val mode : ('m, 'e, 't) lam -> 'm mode = 
+|}];;
 
 type (_,_) sub =
   | Id : ('r,'r) sub
@@ -761,6 +1155,15 @@ let rec subst : type m1 r t s. (m1,r,t) lam -> (r,s) sub -> (s,t) lam' =
   | Lam(v,x), sub ->
       (match subst x (Push sub) with Ex body -> Ex (Lam (v, body)))
 ;;
+[%%expect{|
+type (_, _) sub =
+    Id : ('r, 'r) sub
+  | Bind : 't * ('m, 'r2, 'x) lam *
+      ('r, 'r2) sub -> (('t, 'x, 'r) rcons, 'r2) sub
+  | Push : ('r1, 'r2) sub -> (('a, 'b, 'r1) rcons, ('a, 'b, 'r2) rcons) sub
+type (_, _) lam' = Ex : ('m, 's, 't) lam -> ('s, 't) lam'
+val subst : ('m1, 'r, 't) lam -> ('r, 's) sub -> ('s, 't) lam' = 
+|}];;
 
 type closed = rnil
 
@@ -780,6 +1183,14 @@ let rec rule : type a b.
   | Const (IntTo b, f), Const (IntR, x) ->
       Inr (Const (b, f x))
 ;;
+[%%expect{|
+type closed = rnil
+type 'a rlam = ((pexp, closed, 'a) lam, (pval, closed, 'a) lam) sum
+val rule :
+  (pval, closed, ('a, 'b) tarr) lam -> (pval, closed, 'a) lam -> 'b rlam =
+  
+|}];;
+
 let rec onestep : type m t. (m,closed,t) lam -> t rlam = function
   | Lam (v, body) -> Inr (Lam (v, body))
   | Const (r, v)  -> Inr (Const (r, v))
@@ -797,3 +1208,6 @@ let rec onestep : type m t. (m,closed,t) lam -> t rlam = function
           end
       | Pval, Pval -> rule e1 e2
 ;;
+[%%expect{|
+val onestep : ('m, closed, 't) lam -> 't rlam = 
+|}];;
diff --git a/testsuite/tests/typing-gadts/omega07.ml.principal.reference b/testsuite/tests/typing-gadts/omega07.ml.principal.reference
deleted file mode 100644
index 6ae426a5..00000000
--- a/testsuite/tests/typing-gadts/omega07.ml.principal.reference
+++ /dev/null
@@ -1,304 +0,0 @@
-
-# * * * * *                       type ('a, 'b) sum = Inl of 'a | Inr of 'b
-type zero = Zero
-type 'a succ = Succ of 'a
-type _ nat = NZ : zero nat | NS : 'a nat -> 'a succ nat
-#             type (_, _) seq =
-    Snil : ('a, zero) seq
-  | Scons : 'a * ('a, 'n) seq -> ('a, 'n succ) seq
-#   val l1 : (int, zero succ succ) seq = Scons (3, Scons (5, Snil))
-#       *         type (_, _, _) plus =
-    PlusZ : 'a nat -> (zero, 'a, 'a) plus
-  | PlusS : ('a, 'b, 'c) plus -> ('a succ, 'b, 'c succ) plus
-#         val length : ('a, 'n) seq -> 'n nat = 
-#   *                     type (_, _, _) app =
-    App : ('a, 'p) seq * ('n, 'm, 'p) plus -> ('a, 'n, 'm) app
-val app : ('a, 'n) seq -> ('a, 'm) seq -> ('a, 'n, 'm) app = 
-#                         type tp = TP
-type nd = ND
-type ('a, 'b) fk = FK
-type _ shape =
-    Tp : tp shape
-  | Nd : nd shape
-  | Fk : 'a shape * 'b shape -> ('a, 'b) fk shape
-#           type tt = TT
-type ff = FF
-type _ boolean = BT : tt boolean | BF : ff boolean
-#                 type (_, _) path =
-    Pnone : 'a -> (tp, 'a) path
-  | Phere : (nd, 'a) path
-  | Pleft : ('x, 'a) path -> (('x, 'y) fk, 'a) path
-  | Pright : ('y, 'a) path -> (('x, 'y) fk, 'a) path
-#         type (_, _) tree =
-    Ttip : (tp, 'a) tree
-  | Tnode : 'a -> (nd, 'a) tree
-  | Tfork : ('x, 'a) tree * ('y, 'a) tree -> (('x, 'y) fk, 'a) tree
-#   val tree1 : (((tp, nd) fk, (nd, nd) fk) fk, int) tree =
-  Tfork (Tfork (Ttip, Tnode 4), Tfork (Tnode 4, Tnode 3))
-#                     val find : ('a -> 'a -> bool) -> 'a -> ('sh, 'a) tree -> ('sh, 'a) path list =
-  
-#             val extract : ('sh, 'a) path -> ('sh, 'a) tree -> 'a = 
-#             type (_, _) le =
-    LeZ : 'a nat -> (zero, 'a) le
-  | LeS : ('n, 'm) le -> ('n succ, 'm succ) le
-#       type _ even = EvenZ : zero even | EvenSS : 'n even -> 'n succ succ even
-#         type one = zero succ
-type two = one succ
-type three = two succ
-type four = three succ
-#       val even0 : zero even = EvenZ
-val even2 : two even = EvenSS EvenZ
-val even4 : four even = EvenSS (EvenSS EvenZ)
-#   val p1 : (two, one, three) plus = PlusS (PlusS (PlusZ (NS NZ)))
-#         val summandLessThanSum : ('a, 'b, 'c) plus -> ('a, 'c) le = 
-#                                 type (_, _) equal = Eq : ('a, 'a) equal
-val convert : ('a, 'b) equal -> 'a -> 'b = 
-val sameNat : 'a nat -> 'b nat -> ('a, 'b) equal option = 
-#                                         val plus_func : ('a, 'b, 'm) plus -> ('a, 'b, 'n) plus -> ('m, 'n) equal =
-  
-val plus_assoc :
-  ('a, 'b, 'ab) plus ->
-  ('ab, 'c, 'm) plus ->
-  ('b, 'c, 'bc) plus -> ('a, 'bc, 'n) plus -> ('m, 'n) equal = 
-#             val smaller : ('a succ, 'b succ) le -> ('a, 'b) le = 
-#   type (_, _) diff = Diff : 'c nat * ('a, 'c, 'b) plus -> ('a, 'b) diff
-#   * * * * * * * * *                 val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = 
-#                 val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = 
-#               val diff : ('a, 'b) le -> 'b nat -> ('a, 'b) diff = 
-#             type (_, _) filter = Filter : ('m, 'n) le * ('a, 'm) seq -> ('a, 'n) filter
-val leS' : ('m, 'n) le -> ('m, 'n succ) le = 
-#                   val filter : ('a -> bool) -> ('a, 'n) seq -> ('a, 'n) filter = 
-#                             type (_, _, _) balance =
-    Less : ('h, 'h succ, 'h succ) balance
-  | Same : ('h, 'h, 'h) balance
-  | More : ('h succ, 'h, 'h succ) balance
-type _ avl =
-    Leaf : zero avl
-  | Node : ('hL, 'hR, 'hMax) balance * 'hL avl * int *
-      'hR avl -> 'hMax succ avl
-type avl' = Avl : 'h avl -> avl'
-#                 val empty : avl' = Avl Leaf
-val elem : int -> 'h avl -> bool = 
-#                           val rotr :
-  'n succ succ avl ->
-  int -> 'n avl -> ('n succ succ avl, 'n succ succ succ avl) sum = 
-#                         val rotl :
-  'n avl ->
-  int -> 'n succ succ avl -> ('n succ succ avl, 'n succ succ succ avl) sum =
-  
-#                                               val ins : int -> 'n avl -> ('n avl, 'n succ avl) sum = 
-#           val insert : int -> avl' -> avl' = 
-#                                                                                                                                 val del_min : 'n succ avl -> int * ('n avl, 'n succ avl) sum = 
-type _ avl_del =
-    Dsame : 'n avl -> 'n avl_del
-  | Ddecr : ('m succ, 'n) equal * 'm avl -> 'n avl_del
-val del : int -> 'n avl -> 'n avl_del = 
-#           val delete : int -> avl' -> avl' = 
-#                             type red = RED
-type black = BLACK
-type (_, _) sub_tree =
-    Bleaf : (black, zero) sub_tree
-  | Rnode : (black, 'n) sub_tree * int *
-      (black, 'n) sub_tree -> (red, 'n) sub_tree
-  | Bnode : ('cL, 'n) sub_tree * int *
-      ('cR, 'n) sub_tree -> (black, 'n succ) sub_tree
-type rb_tree = Root : (black, 'n) sub_tree -> rb_tree
-#               type dir = LeftD | RightD
-type (_, _) ctxt =
-    CNil : (black, 'n) ctxt
-  | CRed : int * dir * (black, 'n) sub_tree *
-      (red, 'n) ctxt -> (black, 'n) ctxt
-  | CBlk : int * dir * ('c1, 'n) sub_tree *
-      (black, 'n succ) ctxt -> ('c, 'n) ctxt
-#                         val blacken : (red, 'a) sub_tree -> (black, 'a succ) sub_tree = 
-type _ crep = Red : red crep | Black : black crep
-val color : ('c, 'n) sub_tree -> 'c crep = 
-#                   val fill : ('c, 'n) ctxt -> ('c, 'n) sub_tree -> rb_tree = 
-#             val recolor :
-  dir ->
-  int ->
-  ('a, 'b) sub_tree ->
-  dir ->
-  int ->
-  (black, 'b succ) sub_tree -> ('c, 'b) sub_tree -> (red, 'b succ) sub_tree =
-  
-#             val rotate :
-  dir ->
-  int ->
-  (black, 'a) sub_tree ->
-  dir ->
-  int ->
-  (black, 'a) sub_tree -> (red, 'a) sub_tree -> (black, 'a succ) sub_tree =
-  
-#                     val repair : (red, 'n) sub_tree -> ('c, 'n) ctxt -> rb_tree = 
-#                     val ins : int -> ('c, 'n) sub_tree -> ('c, 'n) ctxt -> rb_tree = 
-#   val insert : int -> rb_tree -> rb_tree = 
-#                                                                                                 type _ term =
-    Const : int -> int term
-  | Add : (int * int -> int) term
-  | LT : (int * int -> bool) term
-  | Ap : ('a -> 'b) term * 'a term -> 'b term
-  | Pair : 'a term * 'b term -> ('a * 'b) term
-val ex1 : int term = Ap (Add, Pair (Const 3, Const 5))
-val ex2 : (int * int) term =
-  Pair (Ap (Add, Pair (Const 3, Const 5)), Const 1)
-val eval_term : 'a term -> 'a = 
-type _ rep =
-    Rint : int rep
-  | Rbool : bool rep
-  | Rpair : 'a rep * 'b rep -> ('a * 'b) rep
-  | Rfun : 'a rep * 'b rep -> ('a -> 'b) rep
-type (_, _) equal = Eq : ('a, 'a) equal
-val rep_equal : 'a rep -> 'b rep -> ('a, 'b) equal option = 
-#                                                               type assoc = Assoc : string * 'a rep * 'a -> assoc
-val assoc : string -> 'a rep -> assoc list -> 'a = 
-type _ term =
-    Var : string * 'a rep -> 'a term
-  | Abs : string * 'a rep * 'b term -> ('a -> 'b) term
-  | Const : int -> int term
-  | Add : (int * int -> int) term
-  | LT : (int * int -> bool) term
-  | Ap : ('a -> 'b) term * 'a term -> 'b term
-  | Pair : 'a term * 'b term -> ('a * 'b) term
-val eval_term : assoc list -> 'a term -> 'a = 
-#           val ex3 : (int -> int) term =
-  Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint))))
-val ex4 : int term =
-  Ap (Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint)))),
-   Const 3)
-val v4 : int = 6
-#                                             type rnil = RNIL
-type ('a, 'b, 'c) rcons = RCons of 'a * 'b * 'c
-type _ is_row =
-    Rnil : rnil is_row
-  | Rcons : 'c is_row -> ('a, 'b, 'c) rcons is_row
-type (_, _) lam =
-    Const : int -> ('e, int) lam
-  | Var : 'a -> (('a, 't, 'e) rcons, 't) lam
-  | Shift : ('e, 't) lam -> (('a, 'q, 'e) rcons, 't) lam
-  | Abs : 'a * (('a, 's, 'e) rcons, 't) lam -> ('e, 's -> 't) lam
-  | App : ('e, 's -> 't) lam * ('e, 's) lam -> ('e, 't) lam
-type x = X
-type y = Y
-val ex1 : ((x, 'a -> 'b, (y, 'a, 'c) rcons) rcons, 'b) lam =
-  App (Var X, Shift (Var Y))
-val ex2 : ('a, ('b -> 'c) -> 'b -> 'c) lam =
-  Abs (, Abs (, App (Shift (Var ), Var )))
-#                           type _ env =
-    Enil : rnil env
-  | Econs : 'a * 't * 'e env -> ('a, 't, 'e) rcons env
-val eval_lam : 'e env -> ('e, 't) lam -> 't = 
-#                               type add = Add
-type suc = Suc
-val env0 :
-  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
-  rcons env = Econs (Zero, 0, Econs (Suc, , Econs (Add, , Enil)))
-val _0 : ((zero, int, 'a) rcons, int) lam = Var Zero
-val suc :
-  (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam ->
-  (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam = 
-val _1 :
-  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
-   rcons, int)
-  lam = App (Shift (Var Suc), Var Zero)
-val _2 :
-  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
-   rcons, int)
-  lam = App (Shift (Var Suc), App (Shift (Var Suc), Var Zero))
-val _3 :
-  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
-   rcons, int)
-  lam =
-  App (Shift (Var Suc),
-   App (Shift (Var Suc), App (Shift (Var Suc), Var Zero)))
-val add :
-  (('a, 'b, ('c, 'd, (add, int -> int -> int, 'e) rcons) rcons) rcons,
-   int -> int -> int)
-  lam = Shift (Shift (Var Add))
-val double :
-  (('a, 'b, ('c, 'd, (add, int -> int -> int, 'e) rcons) rcons) rcons,
-   int -> int)
-  lam =
-  Abs (,
-   App (App (Shift (Shift (Shift (Var Add))), Var ), Var ))
-val ex3 :
-  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
-   rcons, int)
-  lam =
-  App
-   (Abs (,
-     App (App (Shift (Shift (Shift (Var Add))), Var ), Var )),
-   App (Shift (Var Suc),
-    App (Shift (Var Suc), App (Shift (Var Suc), Var Zero))))
-#     val v3 : int = 6
-#       *                                       type _ rep = I : int rep | Ar : 'a rep * 'b rep -> ('a -> 'b) rep
-val compare : 'a rep -> 'b rep -> (string, ('a, 'b) equal) sum = 
-#                     type term =
-    C of int
-  | Ab : string * 'a rep * term -> term
-  | Ap of term * term
-  | V of string
-type _ ctx =
-    Cnil : rnil ctx
-  | Ccons : 't * string * 'x rep * 'e ctx -> ('t, 'x, 'e) rcons ctx
-#                             type _ checked = Cerror of string | Cok : ('e, 't) lam * 't rep -> 'e checked
-val lookup : string -> 'e ctx -> 'e checked = 
-#                                                   val tc : 'n nat -> 'e ctx -> term -> 'e checked = 
-#             val ctx0 :
-  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
-  rcons ctx =
-  Ccons (Zero, "0", I,
-   Ccons (Suc, "S", Ar (I, I), Ccons (Add, "+", Ar (I, Ar (I, I)), Cnil)))
-val ex1 : term = Ab ("x", I, Ap (Ap (V "+", V "x"), V "x"))
-# val c1 :
-  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
-  rcons checked =
-  Cok
-   (Abs (,
-     App (App (Shift (Shift (Shift (Var Add))), Var ), Var )),
-   Ar (I, I))
-# val ex2 : term = Ap (Ab ("x", I, Ap (Ap (V "+", V "x"), V "x")), C 3)
-# val c2 :
-  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
-  rcons checked =
-  Cok
-   (App
-     (Abs (,
-       App (App (Shift (Shift (Shift (Var Add))), Var ), Var )),
-     Const 3),
-   I)
-#           val eval_checked : 'a env -> 'a checked -> int = 
-#   val v2 : int = 6
-#                                             type pexp = PEXP
-type pval = PVAL
-type _ mode = Pexp : pexp mode | Pval : pval mode
-type ('a, 'b) tarr = TARR
-type tint = TINT
-type (_, _) rel =
-    IntR : (tint, int) rel
-  | IntTo : ('b, 's) rel -> ((tint, 'b) tarr, int -> 's) rel
-type (_, _, _) lam =
-    Const : ('a, 'b) rel * 'b -> (pval, 'env, 'a) lam
-  | Var : 'a -> (pval, ('a, 't, 'e) rcons, 't) lam
-  | Shift : ('m, 'e, 't) lam -> ('m, ('a, 'q, 'e) rcons, 't) lam
-  | Lam : 'a *
-      ('m, ('a, 's, 'e) rcons, 't) lam -> (pval, 'e, ('s, 't) tarr) lam
-  | App : ('m1, 'e, ('s, 't) tarr) lam *
-      ('m2, 'e, 's) lam -> (pexp, 'e, 't) lam
-#                   val ex1 : (pexp, 'a, tint) lam =
-  App (Lam (, Var ), Const (IntR, ))
-val mode : ('m, 'e, 't) lam -> 'm mode = 
-#               type (_, _) sub =
-    Id : ('r, 'r) sub
-  | Bind : 't * ('m, 'r2, 'x) lam *
-      ('r, 'r2) sub -> (('t, 'x, 'r) rcons, 'r2) sub
-  | Push : ('r1, 'r2) sub -> (('a, 'b, 'r1) rcons, ('a, 'b, 'r2) rcons) sub
-type (_, _) lam' = Ex : ('m, 's, 't) lam -> ('s, 't) lam'
-#                               val subst : ('m1, 'r, 't) lam -> ('r, 's) sub -> ('s, 't) lam' = 
-#       type closed = rnil
-type 'a rlam = ((pexp, closed, 'a) lam, (pval, closed, 'a) lam) sum
-#                             val rule :
-  (pval, closed, ('a, 'b) tarr) lam -> (pval, closed, 'a) lam -> 'b rlam =
-  
-#                                 val onestep : ('m, closed, 't) lam -> 't rlam = 
-# 
diff --git a/testsuite/tests/typing-gadts/omega07.ml.reference b/testsuite/tests/typing-gadts/omega07.ml.reference
deleted file mode 100644
index 6ae426a5..00000000
--- a/testsuite/tests/typing-gadts/omega07.ml.reference
+++ /dev/null
@@ -1,304 +0,0 @@
-
-# * * * * *                       type ('a, 'b) sum = Inl of 'a | Inr of 'b
-type zero = Zero
-type 'a succ = Succ of 'a
-type _ nat = NZ : zero nat | NS : 'a nat -> 'a succ nat
-#             type (_, _) seq =
-    Snil : ('a, zero) seq
-  | Scons : 'a * ('a, 'n) seq -> ('a, 'n succ) seq
-#   val l1 : (int, zero succ succ) seq = Scons (3, Scons (5, Snil))
-#       *         type (_, _, _) plus =
-    PlusZ : 'a nat -> (zero, 'a, 'a) plus
-  | PlusS : ('a, 'b, 'c) plus -> ('a succ, 'b, 'c succ) plus
-#         val length : ('a, 'n) seq -> 'n nat = 
-#   *                     type (_, _, _) app =
-    App : ('a, 'p) seq * ('n, 'm, 'p) plus -> ('a, 'n, 'm) app
-val app : ('a, 'n) seq -> ('a, 'm) seq -> ('a, 'n, 'm) app = 
-#                         type tp = TP
-type nd = ND
-type ('a, 'b) fk = FK
-type _ shape =
-    Tp : tp shape
-  | Nd : nd shape
-  | Fk : 'a shape * 'b shape -> ('a, 'b) fk shape
-#           type tt = TT
-type ff = FF
-type _ boolean = BT : tt boolean | BF : ff boolean
-#                 type (_, _) path =
-    Pnone : 'a -> (tp, 'a) path
-  | Phere : (nd, 'a) path
-  | Pleft : ('x, 'a) path -> (('x, 'y) fk, 'a) path
-  | Pright : ('y, 'a) path -> (('x, 'y) fk, 'a) path
-#         type (_, _) tree =
-    Ttip : (tp, 'a) tree
-  | Tnode : 'a -> (nd, 'a) tree
-  | Tfork : ('x, 'a) tree * ('y, 'a) tree -> (('x, 'y) fk, 'a) tree
-#   val tree1 : (((tp, nd) fk, (nd, nd) fk) fk, int) tree =
-  Tfork (Tfork (Ttip, Tnode 4), Tfork (Tnode 4, Tnode 3))
-#                     val find : ('a -> 'a -> bool) -> 'a -> ('sh, 'a) tree -> ('sh, 'a) path list =
-  
-#             val extract : ('sh, 'a) path -> ('sh, 'a) tree -> 'a = 
-#             type (_, _) le =
-    LeZ : 'a nat -> (zero, 'a) le
-  | LeS : ('n, 'm) le -> ('n succ, 'm succ) le
-#       type _ even = EvenZ : zero even | EvenSS : 'n even -> 'n succ succ even
-#         type one = zero succ
-type two = one succ
-type three = two succ
-type four = three succ
-#       val even0 : zero even = EvenZ
-val even2 : two even = EvenSS EvenZ
-val even4 : four even = EvenSS (EvenSS EvenZ)
-#   val p1 : (two, one, three) plus = PlusS (PlusS (PlusZ (NS NZ)))
-#         val summandLessThanSum : ('a, 'b, 'c) plus -> ('a, 'c) le = 
-#                                 type (_, _) equal = Eq : ('a, 'a) equal
-val convert : ('a, 'b) equal -> 'a -> 'b = 
-val sameNat : 'a nat -> 'b nat -> ('a, 'b) equal option = 
-#                                         val plus_func : ('a, 'b, 'm) plus -> ('a, 'b, 'n) plus -> ('m, 'n) equal =
-  
-val plus_assoc :
-  ('a, 'b, 'ab) plus ->
-  ('ab, 'c, 'm) plus ->
-  ('b, 'c, 'bc) plus -> ('a, 'bc, 'n) plus -> ('m, 'n) equal = 
-#             val smaller : ('a succ, 'b succ) le -> ('a, 'b) le = 
-#   type (_, _) diff = Diff : 'c nat * ('a, 'c, 'b) plus -> ('a, 'b) diff
-#   * * * * * * * * *                 val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = 
-#                 val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = 
-#               val diff : ('a, 'b) le -> 'b nat -> ('a, 'b) diff = 
-#             type (_, _) filter = Filter : ('m, 'n) le * ('a, 'm) seq -> ('a, 'n) filter
-val leS' : ('m, 'n) le -> ('m, 'n succ) le = 
-#                   val filter : ('a -> bool) -> ('a, 'n) seq -> ('a, 'n) filter = 
-#                             type (_, _, _) balance =
-    Less : ('h, 'h succ, 'h succ) balance
-  | Same : ('h, 'h, 'h) balance
-  | More : ('h succ, 'h, 'h succ) balance
-type _ avl =
-    Leaf : zero avl
-  | Node : ('hL, 'hR, 'hMax) balance * 'hL avl * int *
-      'hR avl -> 'hMax succ avl
-type avl' = Avl : 'h avl -> avl'
-#                 val empty : avl' = Avl Leaf
-val elem : int -> 'h avl -> bool = 
-#                           val rotr :
-  'n succ succ avl ->
-  int -> 'n avl -> ('n succ succ avl, 'n succ succ succ avl) sum = 
-#                         val rotl :
-  'n avl ->
-  int -> 'n succ succ avl -> ('n succ succ avl, 'n succ succ succ avl) sum =
-  
-#                                               val ins : int -> 'n avl -> ('n avl, 'n succ avl) sum = 
-#           val insert : int -> avl' -> avl' = 
-#                                                                                                                                 val del_min : 'n succ avl -> int * ('n avl, 'n succ avl) sum = 
-type _ avl_del =
-    Dsame : 'n avl -> 'n avl_del
-  | Ddecr : ('m succ, 'n) equal * 'm avl -> 'n avl_del
-val del : int -> 'n avl -> 'n avl_del = 
-#           val delete : int -> avl' -> avl' = 
-#                             type red = RED
-type black = BLACK
-type (_, _) sub_tree =
-    Bleaf : (black, zero) sub_tree
-  | Rnode : (black, 'n) sub_tree * int *
-      (black, 'n) sub_tree -> (red, 'n) sub_tree
-  | Bnode : ('cL, 'n) sub_tree * int *
-      ('cR, 'n) sub_tree -> (black, 'n succ) sub_tree
-type rb_tree = Root : (black, 'n) sub_tree -> rb_tree
-#               type dir = LeftD | RightD
-type (_, _) ctxt =
-    CNil : (black, 'n) ctxt
-  | CRed : int * dir * (black, 'n) sub_tree *
-      (red, 'n) ctxt -> (black, 'n) ctxt
-  | CBlk : int * dir * ('c1, 'n) sub_tree *
-      (black, 'n succ) ctxt -> ('c, 'n) ctxt
-#                         val blacken : (red, 'a) sub_tree -> (black, 'a succ) sub_tree = 
-type _ crep = Red : red crep | Black : black crep
-val color : ('c, 'n) sub_tree -> 'c crep = 
-#                   val fill : ('c, 'n) ctxt -> ('c, 'n) sub_tree -> rb_tree = 
-#             val recolor :
-  dir ->
-  int ->
-  ('a, 'b) sub_tree ->
-  dir ->
-  int ->
-  (black, 'b succ) sub_tree -> ('c, 'b) sub_tree -> (red, 'b succ) sub_tree =
-  
-#             val rotate :
-  dir ->
-  int ->
-  (black, 'a) sub_tree ->
-  dir ->
-  int ->
-  (black, 'a) sub_tree -> (red, 'a) sub_tree -> (black, 'a succ) sub_tree =
-  
-#                     val repair : (red, 'n) sub_tree -> ('c, 'n) ctxt -> rb_tree = 
-#                     val ins : int -> ('c, 'n) sub_tree -> ('c, 'n) ctxt -> rb_tree = 
-#   val insert : int -> rb_tree -> rb_tree = 
-#                                                                                                 type _ term =
-    Const : int -> int term
-  | Add : (int * int -> int) term
-  | LT : (int * int -> bool) term
-  | Ap : ('a -> 'b) term * 'a term -> 'b term
-  | Pair : 'a term * 'b term -> ('a * 'b) term
-val ex1 : int term = Ap (Add, Pair (Const 3, Const 5))
-val ex2 : (int * int) term =
-  Pair (Ap (Add, Pair (Const 3, Const 5)), Const 1)
-val eval_term : 'a term -> 'a = 
-type _ rep =
-    Rint : int rep
-  | Rbool : bool rep
-  | Rpair : 'a rep * 'b rep -> ('a * 'b) rep
-  | Rfun : 'a rep * 'b rep -> ('a -> 'b) rep
-type (_, _) equal = Eq : ('a, 'a) equal
-val rep_equal : 'a rep -> 'b rep -> ('a, 'b) equal option = 
-#                                                               type assoc = Assoc : string * 'a rep * 'a -> assoc
-val assoc : string -> 'a rep -> assoc list -> 'a = 
-type _ term =
-    Var : string * 'a rep -> 'a term
-  | Abs : string * 'a rep * 'b term -> ('a -> 'b) term
-  | Const : int -> int term
-  | Add : (int * int -> int) term
-  | LT : (int * int -> bool) term
-  | Ap : ('a -> 'b) term * 'a term -> 'b term
-  | Pair : 'a term * 'b term -> ('a * 'b) term
-val eval_term : assoc list -> 'a term -> 'a = 
-#           val ex3 : (int -> int) term =
-  Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint))))
-val ex4 : int term =
-  Ap (Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint)))),
-   Const 3)
-val v4 : int = 6
-#                                             type rnil = RNIL
-type ('a, 'b, 'c) rcons = RCons of 'a * 'b * 'c
-type _ is_row =
-    Rnil : rnil is_row
-  | Rcons : 'c is_row -> ('a, 'b, 'c) rcons is_row
-type (_, _) lam =
-    Const : int -> ('e, int) lam
-  | Var : 'a -> (('a, 't, 'e) rcons, 't) lam
-  | Shift : ('e, 't) lam -> (('a, 'q, 'e) rcons, 't) lam
-  | Abs : 'a * (('a, 's, 'e) rcons, 't) lam -> ('e, 's -> 't) lam
-  | App : ('e, 's -> 't) lam * ('e, 's) lam -> ('e, 't) lam
-type x = X
-type y = Y
-val ex1 : ((x, 'a -> 'b, (y, 'a, 'c) rcons) rcons, 'b) lam =
-  App (Var X, Shift (Var Y))
-val ex2 : ('a, ('b -> 'c) -> 'b -> 'c) lam =
-  Abs (, Abs (, App (Shift (Var ), Var )))
-#                           type _ env =
-    Enil : rnil env
-  | Econs : 'a * 't * 'e env -> ('a, 't, 'e) rcons env
-val eval_lam : 'e env -> ('e, 't) lam -> 't = 
-#                               type add = Add
-type suc = Suc
-val env0 :
-  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
-  rcons env = Econs (Zero, 0, Econs (Suc, , Econs (Add, , Enil)))
-val _0 : ((zero, int, 'a) rcons, int) lam = Var Zero
-val suc :
-  (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam ->
-  (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam = 
-val _1 :
-  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
-   rcons, int)
-  lam = App (Shift (Var Suc), Var Zero)
-val _2 :
-  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
-   rcons, int)
-  lam = App (Shift (Var Suc), App (Shift (Var Suc), Var Zero))
-val _3 :
-  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
-   rcons, int)
-  lam =
-  App (Shift (Var Suc),
-   App (Shift (Var Suc), App (Shift (Var Suc), Var Zero)))
-val add :
-  (('a, 'b, ('c, 'd, (add, int -> int -> int, 'e) rcons) rcons) rcons,
-   int -> int -> int)
-  lam = Shift (Shift (Var Add))
-val double :
-  (('a, 'b, ('c, 'd, (add, int -> int -> int, 'e) rcons) rcons) rcons,
-   int -> int)
-  lam =
-  Abs (,
-   App (App (Shift (Shift (Shift (Var Add))), Var ), Var ))
-val ex3 :
-  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
-   rcons, int)
-  lam =
-  App
-   (Abs (,
-     App (App (Shift (Shift (Shift (Var Add))), Var ), Var )),
-   App (Shift (Var Suc),
-    App (Shift (Var Suc), App (Shift (Var Suc), Var Zero))))
-#     val v3 : int = 6
-#       *                                       type _ rep = I : int rep | Ar : 'a rep * 'b rep -> ('a -> 'b) rep
-val compare : 'a rep -> 'b rep -> (string, ('a, 'b) equal) sum = 
-#                     type term =
-    C of int
-  | Ab : string * 'a rep * term -> term
-  | Ap of term * term
-  | V of string
-type _ ctx =
-    Cnil : rnil ctx
-  | Ccons : 't * string * 'x rep * 'e ctx -> ('t, 'x, 'e) rcons ctx
-#                             type _ checked = Cerror of string | Cok : ('e, 't) lam * 't rep -> 'e checked
-val lookup : string -> 'e ctx -> 'e checked = 
-#                                                   val tc : 'n nat -> 'e ctx -> term -> 'e checked = 
-#             val ctx0 :
-  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
-  rcons ctx =
-  Ccons (Zero, "0", I,
-   Ccons (Suc, "S", Ar (I, I), Ccons (Add, "+", Ar (I, Ar (I, I)), Cnil)))
-val ex1 : term = Ab ("x", I, Ap (Ap (V "+", V "x"), V "x"))
-# val c1 :
-  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
-  rcons checked =
-  Cok
-   (Abs (,
-     App (App (Shift (Shift (Shift (Var Add))), Var ), Var )),
-   Ar (I, I))
-# val ex2 : term = Ap (Ab ("x", I, Ap (Ap (V "+", V "x"), V "x")), C 3)
-# val c2 :
-  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
-  rcons checked =
-  Cok
-   (App
-     (Abs (,
-       App (App (Shift (Shift (Shift (Var Add))), Var ), Var )),
-     Const 3),
-   I)
-#           val eval_checked : 'a env -> 'a checked -> int = 
-#   val v2 : int = 6
-#                                             type pexp = PEXP
-type pval = PVAL
-type _ mode = Pexp : pexp mode | Pval : pval mode
-type ('a, 'b) tarr = TARR
-type tint = TINT
-type (_, _) rel =
-    IntR : (tint, int) rel
-  | IntTo : ('b, 's) rel -> ((tint, 'b) tarr, int -> 's) rel
-type (_, _, _) lam =
-    Const : ('a, 'b) rel * 'b -> (pval, 'env, 'a) lam
-  | Var : 'a -> (pval, ('a, 't, 'e) rcons, 't) lam
-  | Shift : ('m, 'e, 't) lam -> ('m, ('a, 'q, 'e) rcons, 't) lam
-  | Lam : 'a *
-      ('m, ('a, 's, 'e) rcons, 't) lam -> (pval, 'e, ('s, 't) tarr) lam
-  | App : ('m1, 'e, ('s, 't) tarr) lam *
-      ('m2, 'e, 's) lam -> (pexp, 'e, 't) lam
-#                   val ex1 : (pexp, 'a, tint) lam =
-  App (Lam (, Var ), Const (IntR, ))
-val mode : ('m, 'e, 't) lam -> 'm mode = 
-#               type (_, _) sub =
-    Id : ('r, 'r) sub
-  | Bind : 't * ('m, 'r2, 'x) lam *
-      ('r, 'r2) sub -> (('t, 'x, 'r) rcons, 'r2) sub
-  | Push : ('r1, 'r2) sub -> (('a, 'b, 'r1) rcons, ('a, 'b, 'r2) rcons) sub
-type (_, _) lam' = Ex : ('m, 's, 't) lam -> ('s, 't) lam'
-#                               val subst : ('m1, 'r, 't) lam -> ('r, 's) sub -> ('s, 't) lam' = 
-#       type closed = rnil
-type 'a rlam = ((pexp, closed, 'a) lam, (pval, closed, 'a) lam) sum
-#                             val rule :
-  (pval, closed, ('a, 'b) tarr) lam -> (pval, closed, 'a) lam -> 'b rlam =
-  
-#                                 val onestep : ('m, closed, 't) lam -> 't rlam = 
-# 
diff --git a/testsuite/tests/typing-gadts/pr5332.ml b/testsuite/tests/typing-gadts/pr5332.ml
index 700e37b1..e0c77acd 100644
--- a/testsuite/tests/typing-gadts/pr5332.ml
+++ b/testsuite/tests/typing-gadts/pr5332.ml
@@ -14,4 +14,16 @@ let f : type env a. (env, a) typ -> (env, a) typ -> int = fun ta tb ->
    | Tvar var, tb -> 2
    | _ -> .   (* error *)
 ;;
+[%%expect{|
+type ('env, 'a) var =
+    Zero : ('a * 'env, 'a) var
+  | Succ : ('env, 'a) var -> ('b * 'env, 'a) var
+type ('env, 'a) typ =
+    Tint : ('env, int) typ
+  | Tbool : ('env, bool) typ
+  | Tvar : ('env, 'a) var -> ('env, 'a) typ
+Line _, characters 5-6:
+Error: This match case could not be refuted.
+       Here is an example of a value that would reach it: (Tint, Tvar Zero)
+|}];;
 (* let x = f Tint (Tvar Zero) ;; *)
diff --git a/testsuite/tests/typing-gadts/pr5332.ml.reference b/testsuite/tests/typing-gadts/pr5332.ml.reference
deleted file mode 100644
index 3abbcfff..00000000
--- a/testsuite/tests/typing-gadts/pr5332.ml.reference
+++ /dev/null
@@ -1,14 +0,0 @@
-
-#       type ('env, 'a) var =
-    Zero : ('a * 'env, 'a) var
-  | Succ : ('env, 'a) var -> ('b * 'env, 'a) var
-#         type ('env, 'a) typ =
-    Tint : ('env, int) typ
-  | Tbool : ('env, bool) typ
-  | Tvar : ('env, 'a) var -> ('env, 'a) typ
-#             Characters 162-163:
-     | _ -> .   (* error *)
-       ^
-Error: This match case could not be refuted.
-       Here is an example of a value that would reach it: (Tint, Tvar Zero)
-#   
diff --git a/testsuite/tests/typing-gadts/pr5689.ml b/testsuite/tests/typing-gadts/pr5689.ml
index 856ddc27..748212d4 100644
--- a/testsuite/tests/typing-gadts/pr5689.ml
+++ b/testsuite/tests/typing-gadts/pr5689.ml
@@ -15,6 +15,16 @@ let uppercase seq =
        | Mref (lnk, xs) -> Mref (lnk, List.map process xs)
    in List.map process seq
 ;;
+[%%expect{|
+type inkind = [ `Link | `Nonlink ]
+type _ inline_t =
+    Text : string -> [< inkind > `Nonlink ] inline_t
+  | Bold : 'a inline_t list -> 'a inline_t
+  | Link : string -> [< inkind > `Link ] inline_t
+  | Mref : string *
+      [ `Nonlink ] inline_t list -> [< inkind > `Link ] inline_t
+val uppercase : 'a inline_t list -> 'a inline_t list = 
+|}];;
 
 type ast_t =
    | Ast_Text of string
@@ -35,6 +45,14 @@ let inlineseq_from_astseq seq =
        | Ast_Mref (lnk, xs) -> Mref (lnk, List.map process_nonlink xs)
    in List.map process_any seq
 ;;
+[%%expect{|
+type ast_t =
+    Ast_Text of string
+  | Ast_Bold of ast_t list
+  | Ast_Link of string
+  | Ast_Mref of string * ast_t list
+val inlineseq_from_astseq : ast_t list -> inkind inline_t list = 
+|}];;
 
 (* OK *)
 type _ linkp =
@@ -55,6 +73,10 @@ let inlineseq_from_astseq seq =
      | (Nonlink, Ast_Mref _)      -> assert false
    in List.map (process Maylink) seq
 ;;
+[%%expect{|
+type _ linkp = Nonlink : [ `Nonlink ] linkp | Maylink : inkind linkp
+val inlineseq_from_astseq : ast_t list -> inkind inline_t list = 
+|}];;
 
 (* Bad *)
 type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2
@@ -72,3 +94,12 @@ let rec process : type a. a linkp2 -> ast_t -> a inline_t =
     | (Kind Nonlink, Ast_Mref _)      -> assert false
   in List.map (process (Kind Maylink)) seq
 ;;
+[%%expect{|
+type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2
+Line _, characters 35-43:
+Error: This expression has type ([< inkind > `Nonlink ] as 'a) inline_t
+       but an expression was expected of type a inline_t
+       Type 'a = [< `Link | `Nonlink > `Nonlink ] is not compatible with type
+         a = [< `Link | `Nonlink ]
+       Types for tag `Nonlink are incompatible
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr5689.ml.principal.reference b/testsuite/tests/typing-gadts/pr5689.ml.principal.reference
deleted file mode 100644
index fabdb17c..00000000
--- a/testsuite/tests/typing-gadts/pr5689.ml.principal.reference
+++ /dev/null
@@ -1,27 +0,0 @@
-
-#               type inkind = [ `Link | `Nonlink ]
-type _ inline_t =
-    Text : string -> [< inkind > `Nonlink ] inline_t
-  | Bold : 'a inline_t list -> 'a inline_t
-  | Link : string -> [< inkind > `Link ] inline_t
-  | Mref : string *
-      [ `Nonlink ] inline_t list -> [< inkind > `Link ] inline_t
-#                 val uppercase : 'a inline_t list -> 'a inline_t list = 
-#             type ast_t =
-    Ast_Text of string
-  | Ast_Bold of ast_t list
-  | Ast_Link of string
-  | Ast_Mref of string * ast_t list
-#                         val inlineseq_from_astseq : ast_t list -> inkind inline_t list = 
-#           type _ linkp = Nonlink : [ `Nonlink ] linkp | Maylink : inkind linkp
-#                           val inlineseq_from_astseq : ast_t list -> inkind inline_t list = 
-#       type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2
-#                         Characters 184-192:
-      | (Kind _, Ast_Text txt)    -> Text txt
-                                     ^^^^^^^^
-Error: This expression has type ([< inkind > `Nonlink ] as 'a) inline_t
-       but an expression was expected of type a inline_t
-       Type 'a = [< `Link | `Nonlink > `Nonlink ] is not compatible with type
-         a = [< `Link | `Nonlink ] 
-       Types for tag `Nonlink are incompatible
-# 
diff --git a/testsuite/tests/typing-gadts/pr5689.ml.reference b/testsuite/tests/typing-gadts/pr5689.ml.reference
deleted file mode 100644
index fabdb17c..00000000
--- a/testsuite/tests/typing-gadts/pr5689.ml.reference
+++ /dev/null
@@ -1,27 +0,0 @@
-
-#               type inkind = [ `Link | `Nonlink ]
-type _ inline_t =
-    Text : string -> [< inkind > `Nonlink ] inline_t
-  | Bold : 'a inline_t list -> 'a inline_t
-  | Link : string -> [< inkind > `Link ] inline_t
-  | Mref : string *
-      [ `Nonlink ] inline_t list -> [< inkind > `Link ] inline_t
-#                 val uppercase : 'a inline_t list -> 'a inline_t list = 
-#             type ast_t =
-    Ast_Text of string
-  | Ast_Bold of ast_t list
-  | Ast_Link of string
-  | Ast_Mref of string * ast_t list
-#                         val inlineseq_from_astseq : ast_t list -> inkind inline_t list = 
-#           type _ linkp = Nonlink : [ `Nonlink ] linkp | Maylink : inkind linkp
-#                           val inlineseq_from_astseq : ast_t list -> inkind inline_t list = 
-#       type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2
-#                         Characters 184-192:
-      | (Kind _, Ast_Text txt)    -> Text txt
-                                     ^^^^^^^^
-Error: This expression has type ([< inkind > `Nonlink ] as 'a) inline_t
-       but an expression was expected of type a inline_t
-       Type 'a = [< `Link | `Nonlink > `Nonlink ] is not compatible with type
-         a = [< `Link | `Nonlink ] 
-       Types for tag `Nonlink are incompatible
-# 
diff --git a/testsuite/tests/typing-gadts/pr5785.ml b/testsuite/tests/typing-gadts/pr5785.ml
index fdfa7ebf..9624adcd 100644
--- a/testsuite/tests/typing-gadts/pr5785.ml
+++ b/testsuite/tests/typing-gadts/pr5785.ml
@@ -8,3 +8,15 @@ struct
     | One, One -> "two"
     | Two, Two -> "four"
 end;;
+[%%expect{|
+Line _, characters 43-100:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(Two, One)
+module Add :
+  functor (T : sig type two end) ->
+    sig
+      type _ t = One : [ `One ] t | Two : T.two t
+      val add : 'a t * 'a t -> string
+    end
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr5785.ml.reference b/testsuite/tests/typing-gadts/pr5785.ml.reference
deleted file mode 100644
index 0a1fb774..00000000
--- a/testsuite/tests/typing-gadts/pr5785.ml.reference
+++ /dev/null
@@ -1,15 +0,0 @@
-
-#                   Characters 137-194:
-  ...........................................function
-      | One, One -> "two"
-      | Two, Two -> "four"
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(Two, One)
-module Add :
-  functor (T : sig type two end) ->
-    sig
-      type _ t = One : [ `One ] t | Two : T.two t
-      val add : 'a t * 'a t -> string
-    end
-# 
diff --git a/testsuite/tests/typing-gadts/pr5848.ml b/testsuite/tests/typing-gadts/pr5848.ml
index c07e30c9..d1ebbdf5 100644
--- a/testsuite/tests/typing-gadts/pr5848.ml
+++ b/testsuite/tests/typing-gadts/pr5848.ml
@@ -12,3 +12,9 @@ let of_type: type a. a -> a = fun x ->
   match B.f x 4 with
   | Eq -> 5
 ;;
+[%%expect{|
+module B :
+  sig type (_, _) t = Eq : ('a, 'a) t val f : 'a -> 'b -> ('a, 'b) t end
+Line _, characters 4-6:
+Error: The GADT constructor Eq of type B.t must be qualified in this pattern.
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr5848.ml.reference b/testsuite/tests/typing-gadts/pr5848.ml.reference
deleted file mode 100644
index 577a6dc4..00000000
--- a/testsuite/tests/typing-gadts/pr5848.ml.reference
+++ /dev/null
@@ -1,8 +0,0 @@
-
-#                 module B :
-  sig type (_, _) t = Eq : ('a, 'a) t val f : 'a -> 'b -> ('a, 'b) t end
-#         Characters 65-67:
-    | Eq -> 5
-      ^^
-Error: The GADT constructor Eq of type B.t must be qualified in this pattern.
-# 
diff --git a/testsuite/tests/typing-gadts/pr5906.ml b/testsuite/tests/typing-gadts/pr5906.ml
index f0b2f0b0..a9541265 100644
--- a/testsuite/tests/typing-gadts/pr5906.ml
+++ b/testsuite/tests/typing-gadts/pr5906.ml
@@ -16,3 +16,18 @@ let eval (type a) (type b) (type c) (bop:(a,b,c) binop) (x:a constant)
   | Add, Int x, Int y -> Int (x + y)
 
 let _ = eval Eq (Int 2) (Int 3)
+
+[%%expect{|
+type _ constant = Int : int -> int constant | Bool : bool -> bool constant
+type (_, _, _) binop =
+    Eq : ('a, 'a, bool) binop
+  | Leq : ('a, 'a, bool) binop
+  | Add : (int, int, int) binop
+Line _, characters 2-195:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(Eq, Int _, _)
+val eval : ('a, 'b, 'c) binop -> 'a constant -> 'b constant -> 'c constant =
+  
+Exception: Match_failure ("", 12, 2).
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr5906.ml.reference b/testsuite/tests/typing-gadts/pr5906.ml.reference
deleted file mode 100644
index 28a103c7..00000000
--- a/testsuite/tests/typing-gadts/pr5906.ml.reference
+++ /dev/null
@@ -1,5 +0,0 @@
-
-#                                     
-Characters 533-533:
-  Error: Syntax error
-# 
diff --git a/testsuite/tests/typing-gadts/pr5948.ml b/testsuite/tests/typing-gadts/pr5948.ml
index 0acc9086..52477628 100644
--- a/testsuite/tests/typing-gadts/pr5948.ml
+++ b/testsuite/tests/typing-gadts/pr5948.ml
@@ -25,6 +25,27 @@ let example6 : type a. a wrapPoly -> (a -> int) =
     | WrapPoly ATag -> intA
     | WrapPoly _ -> intA (* This should not be allowed *)
 ;;
+[%%expect{|
+type tag = [ `TagA | `TagB | `TagC ]
+type 'a poly =
+    AandBTags : [< `TagA of int | `TagB ] poly
+  | ATag : [< `TagA of int ] poly
+val intA : [< `TagA of 'a ] -> 'a = 
+val intB : [< `TagB ] -> int = 
+val intAorB : [< `TagA of int | `TagB ] -> int = 
+type _ wrapPoly =
+    WrapPoly : 'a poly -> ([< `TagA of int | `TagB ] as 'a) wrapPoly
+Line _, characters 23-27:
+Error: This expression has type ([< `TagA of 'b ] as 'a) -> 'b
+       but an expression was expected of type a -> int
+       Type [< `TagA of 'b ] as 'a is not compatible with type
+         a = [< `TagA of int | `TagB ]
+       The first variant type does not allow tag(s) `TagB
+|}];;
 
 let _ =  example6 (WrapPoly AandBTags) `TagB (* This causes a seg fault *)
 ;;
+[%%expect{|
+Line _, characters 9-17:
+Error: Unbound value example6
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr5948.ml.reference b/testsuite/tests/typing-gadts/pr5948.ml.reference
deleted file mode 100644
index 597cbfa6..00000000
--- a/testsuite/tests/typing-gadts/pr5948.ml.reference
+++ /dev/null
@@ -1,23 +0,0 @@
-
-# type tag = [ `TagA | `TagB | `TagC ]
-#           type 'a poly =
-    AandBTags : [< `TagA of int | `TagB ] poly
-  | ATag : [< `TagA of int ] poly
-#       val intA : [< `TagA of 'a ] -> 'a = 
-val intB : [< `TagB ] -> int = 
-#         val intAorB : [< `TagA of int | `TagB ] -> int = 
-#       type _ wrapPoly =
-    WrapPoly : 'a poly -> ([< `TagA of int | `TagB ] as 'a) wrapPoly
-#             Characters 103-107:
-      | WrapPoly ATag -> intA
-                         ^^^^
-Error: This expression has type ([< `TagA of 'b ] as 'a) -> 'b
-       but an expression was expected of type a -> int
-       Type [< `TagA of 'b ] as 'a is not compatible with type
-         a = [< `TagA of int | `TagB ] 
-       The first variant type does not allow tag(s) `TagB
-#     Characters 10-18:
-  let _ =  example6 (WrapPoly AandBTags) `TagB (* This causes a seg fault *)
-           ^^^^^^^^
-Error: Unbound value example6
-# 
diff --git a/testsuite/tests/typing-gadts/pr5981.ml b/testsuite/tests/typing-gadts/pr5981.ml
index f93b4e36..bda9a883 100644
--- a/testsuite/tests/typing-gadts/pr5981.ml
+++ b/testsuite/tests/typing-gadts/pr5981.ml
@@ -7,6 +7,18 @@ module F(S : sig type 'a t end) = struct
     fun (l : int S.t ab) (r : float S.t ab) -> match l, r with
     | A, B -> "f A B"
 end;;
+[%%expect{|
+Line _, characters 47-84:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(A, A)
+module F :
+  functor (S : sig type 'a t end) ->
+    sig
+      type _ ab = A : int S.t ab | B : float S.t ab
+      val f : int S.t ab -> float S.t ab -> string
+    end
+|}];;
 
 module F(S : sig type 'a t end) = struct
   type a = int * int
@@ -20,3 +32,17 @@ module F(S : sig type 'a t end) = struct
     fun l r -> match l, r with
     | A, B -> "f A B"
 end;;
+[%%expect{|
+Line _, characters 15-52:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(A, A)
+module F :
+  functor (S : sig type 'a t end) ->
+    sig
+      type a = int * int
+      type b = int -> int
+      type _ ab = A : a S.t ab | B : b S.t ab
+      val f : a S.t ab -> b S.t ab -> string
+    end
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr5981.ml.reference b/testsuite/tests/typing-gadts/pr5981.ml.reference
deleted file mode 100644
index 3a2d7b16..00000000
--- a/testsuite/tests/typing-gadts/pr5981.ml.reference
+++ /dev/null
@@ -1,28 +0,0 @@
-
-#                 Characters 196-233:
-  ...............................................match l, r with
-      | A, B -> "f A B"
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(A, A)
-module F :
-  functor (S : sig type 'a t end) ->
-    sig
-      type _ ab = A : int S.t ab | B : float S.t ab
-      val f : int S.t ab -> float S.t ab -> string
-    end
-#                         Characters 197-234:
-  ...............match l, r with
-      | A, B -> "f A B"
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(A, A)
-module F :
-  functor (S : sig type 'a t end) ->
-    sig
-      type a = int * int
-      type b = int -> int
-      type _ ab = A : a S.t ab | B : b S.t ab
-      val f : a S.t ab -> b S.t ab -> string
-    end
-# 
diff --git a/testsuite/tests/typing-gadts/pr5985.ml b/testsuite/tests/typing-gadts/pr5985.ml
index 23902add..0243887f 100644
--- a/testsuite/tests/typing-gadts/pr5985.ml
+++ b/testsuite/tests/typing-gadts/pr5985.ml
@@ -3,17 +3,22 @@ module F (S : sig type 'a s end) = struct
   include S
   type _ t = T : 'a -> 'a s t
 end;; (* fail *)
+[%%expect{|
+Line _, characters 2-29:
+Error: In this definition, a type variable cannot be deduced
+       from the type parameters.
+|}];;
 (*
 module M = F (struct type 'a s = int end) ;;
 let M.T x = M.T 3 in x = true;;
 *)
 
 (* Fix it using #-annotations *)
+(*
 module F (S : sig type #'a s end) = struct
   include S
   type _ t = T : 'a -> 'a s t
 end;; (* syntax error *)
-(*
 module M = F (struct type 'a s = int end) ;; (* fail *)
 module M = F (struct type 'a s = new int end) ;; (* ok *)
 let M.T x = M.T 3 in x = true;; (* fail *)
@@ -25,6 +30,11 @@ module F(T:sig type 'a t end) = struct
   class ['a] c x =
     object constraint 'a = 'b T.t val x' : 'b = x method x = x' end
 end;; (* fail *)
+[%%expect{|
+Line _, characters 2-86:
+Error: In this definition, a type variable cannot be deduced
+       from the type parameters.
+|}];;
 
 (* Another (more direct) instance using polymorphic variants *)
 (* PR#6275 *)
@@ -32,7 +42,18 @@ type 'x t = A of 'a constraint 'x = [< `X of 'a ] ;; (* fail *)
 let magic (x : int) : bool  =
   let A x = A x in
   x;; (* fail *)
+[%%expect{|
+Line _, characters 0-49:
+Error: In this definition, a type variable cannot be deduced
+       from the type parameters.
+|}];;
+
 type 'a t = A : 'a -> [< `X of 'a ] t;; (* fail *)
+[%%expect{|
+Line _, characters 0-37:
+Error: In this definition, a type variable cannot be deduced
+       from the type parameters.
+|}];;
 
 (* It is not OK to allow modules exported by other compilation units *)
 type (_,_) eq = Eq : ('a,'a) eq;;
@@ -40,6 +61,14 @@ let eq = Obj.magic Eq;;
 (* pretend that Queue.t is not injective *)
 let eq : ('a Queue.t, 'b Queue.t) eq = eq;;
 type _ t = T : 'a -> 'a Queue.t t;; (* fail *)
+[%%expect{|
+type (_, _) eq = Eq : ('a, 'a) eq
+val eq : 'a = 
+val eq : ('a Queue.t, 'b Queue.t) eq = Eq
+Line _, characters 0-33:
+Error: In this definition, a type variable cannot be deduced
+       from the type parameters.
+|}];;
 (*
 let castT (type a) (type b) (x : a t) (e: (a, b) eq) : b t =
   let Eq = e in (x : b t);;
@@ -51,18 +80,27 @@ module type S = sig
   type 'a s
   type _ t = T : 'a -> 'a s t
 end;; (* fail *)
+[%%expect{|
+Line _, characters 2-29:
+Error: In this definition, a type variable cannot be deduced
+       from the type parameters.
+|}];;
 (* Otherwise we can write the following *)
 module rec M : (S with type 'a s = unit) = M;;
+[%%expect{|
+Line _, characters 16-17:
+Error: Unbound module type S
+|}];;
 (* For the above reason, we cannot allow the abstract declaration
    of s and the definition of t to be in the same module, as
    we could create the signature using [module type of ...] *)
 
 
 (* Another problem with variance *)
+(*
 module M = struct type 'a t = 'a -> unit end;;
 module F(X:sig type #'a t end) =
   struct type +'a s = S of 'b constraint 'a = 'b X.t end;; (* fail *)
-(*
 module N = F(M);;
 let o = N.S (object end);;
 let N.S o' = (o :>  M.t N.s);; (* unsound! *)
@@ -71,20 +109,51 @@ let N.S o' = (o :>  M.t N.s);; (* unsound! *)
 (* And yet another *)
 type 'a q = Q;;
 type +'a t = 'b constraint 'a = 'b q;;
+[%%expect{|
+type 'a q = Q
+Line _, characters 0-36:
+Error: In this definition, a type variable has a variance that
+       cannot be deduced from the type parameters.
+       It was expected to be unrestricted, but it is covariant.
+|}];;
 (* shoud fail: we do not know for sure the variance of Queue.t *)
 
 type +'a t = T of 'a;;
 type +'a s = 'b constraint 'a = 'b t;; (* ok *)
+[%%expect{|
+type 'a t = T of 'a
+type +'a s = 'b constraint 'a = 'b t
+|}];;
 type -'a s = 'b constraint 'a = 'b t;; (* fail *)
+[%%expect{|
+Line _, characters 0-36:
+Error: In this definition, a type variable has a variance that
+       is not reflected by its occurrence in type parameters.
+       It was expected to be contravariant, but it is covariant.
+|}];;
 type +'a u = 'a t;;
 type 'a t = T of ('a -> 'a);;
 type -'a s = 'b constraint 'a = 'b t;; (* ok *)
+[%%expect{|
+type 'a u = 'a t
+type 'a t = T of ('a -> 'a)
+type -'a s = 'b constraint 'a = 'b t
+|}];;
 type +'a s = 'b constraint 'a = 'b q t;; (* ok *)
+[%%expect{|
+type +'a s = 'b constraint 'a = 'b q t
+|}];;
 type +'a s = 'b constraint 'a = 'b t q;; (* fail *)
+[%%expect{|
+Line _, characters 0-38:
+Error: In this definition, a type variable has a variance that
+       cannot be deduced from the type parameters.
+       It was expected to be unrestricted, but it is covariant.
+|}];;
 
 
 (* the problem from lablgtk2 *)
-
+(*
 module Gobject = struct
   type -'a obj
 end
@@ -95,8 +164,14 @@ class virtual ['a] item_container =
    constraint 'a = < as_item : [>`widget] obj; .. >
    method virtual add : 'a -> unit
  end;;
-
+*)
 
 (* Another variance anomaly, should not expand t in g before checking *)
 type +'a t = unit constraint 'a = 'b list;;
 type _ g = G : 'a -> 'a t g;; (* fail *)
+[%%expect{|
+type +'a t = unit constraint 'a = 'b list
+Line _, characters 0-27:
+Error: In this definition, a type variable cannot be deduced
+       from the type parameters.
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr5985.ml.reference b/testsuite/tests/typing-gadts/pr5985.ml.reference
deleted file mode 100644
index 4c29f6da..00000000
--- a/testsuite/tests/typing-gadts/pr5985.ml.reference
+++ /dev/null
@@ -1,89 +0,0 @@
-
-#         Characters 88-115:
-    type _ t = T : 'a -> 'a s t
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In this definition, a type variable cannot be deduced
-       from the type parameters.
-# * * *             Characters 140-141:
-  module F (S : sig type #'a s end) = struct
-                         ^
-Error: Syntax error
-# * * * * *             Characters 290-374:
-  ..class ['a] c x =
-      object constraint 'a = 'b T.t val x' : 'b = x method x = x' end
-Error: In this definition, a type variable cannot be deduced
-       from the type parameters.
-#       Characters 79-128:
-  type 'x t = A of 'a constraint 'x = [< `X of 'a ] ;; (* fail *)
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In this definition, a type variable cannot be deduced
-       from the type parameters.
-#     Characters 36-37:
-    let A x = A x in
-        ^
-Error: Unbound constructor A
-# Characters 0-37:
-  type 'a t = A : 'a -> [< `X of 'a ] t;; (* fail *)
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In this definition, a type variable cannot be deduced
-       from the type parameters.
-#     type (_, _) eq = Eq : ('a, 'a) eq
-# val eq : 'a = 
-#   val eq : ('a Queue.t, 'b Queue.t) eq = Eq
-# Characters 0-33:
-  type _ t = T : 'a -> 'a Queue.t t;; (* fail *)
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In this definition, a type variable cannot be deduced
-       from the type parameters.
-# * * * *             Characters 250-277:
-    type _ t = T : 'a -> 'a s t
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In this definition, a type variable cannot be deduced
-       from the type parameters.
-#   Characters 59-60:
-  module rec M : (S with type 'a s = unit) = M;;
-                  ^
-Error: Unbound module type S
-# * *         module M : sig type 'a t = 'a -> unit end
-#   Characters 20-21:
-  module F(X:sig type #'a t end) =
-                      ^
-Error: Syntax error
-# * * * *       type 'a q = Q
-# Characters 0-36:
-  type +'a t = 'b constraint 'a = 'b q;;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In this definition, a type variable has a variance that
-       cannot be deduced from the type parameters.
-       It was expected to be unrestricted, but it is covariant.
-#     type 'a t = T of 'a
-# type +'a s = 'b constraint 'a = 'b t
-# Characters 0-36:
-  type -'a s = 'b constraint 'a = 'b t;; (* fail *)
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In this definition, a type variable has a variance that
-       is not reflected by its occurrence in type parameters.
-       It was expected to be contravariant, but it is covariant.
-# type 'a u = 'a t
-# type 'a t = T of ('a -> 'a)
-# type -'a s = 'b constraint 'a = 'b t
-# type +'a s = 'b constraint 'a = 'b q t
-# Characters 0-38:
-  type +'a s = 'b constraint 'a = 'b t q;; (* fail *)
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In this definition, a type variable has a variance that
-       cannot be deduced from the type parameters.
-       It was expected to be unrestricted, but it is covariant.
-#               module Gobject : sig type -'a obj end
-#           class virtual ['a] item_container :
-  object
-    constraint 'a = < as_item : [> `widget ] Gobject.obj; .. >
-    method virtual add : 'a -> unit
-  end
-#       type +'a t = unit constraint 'a = 'b list
-# Characters 0-27:
-  type _ g = G : 'a -> 'a t g;; (* fail *)
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In this definition, a type variable cannot be deduced
-       from the type parameters.
-# 
diff --git a/testsuite/tests/typing-gadts/pr5989.ml b/testsuite/tests/typing-gadts/pr5989.ml
index 392df7f2..0abf7cb3 100644
--- a/testsuite/tests/typing-gadts/pr5989.ml
+++ b/testsuite/tests/typing-gadts/pr5989.ml
@@ -18,6 +18,16 @@ let f : (M.s, [`A | `B]) t -> string = function
 ;;
 
 let () = print_endline (f M.eq) ;;
+[%%expect{|
+type (_, _) t = Any : ('a, 'b) t | Eq : ('a, 'a) t
+module M : sig type s = private [> `A ] val eq : (s, [ `A | `B ]) t end
+Line _, characters 39-64:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Eq
+val f : (M.s, [ `A | `B ]) t -> string = 
+Exception: Match_failure ("", 16, 39).
+|}];;
 
 module N :
 sig
@@ -33,3 +43,15 @@ end
 let f : (N.s, ) t -> string = function
   | Any -> "Any"
 ;;
+[%%expect{|
+module N :
+  sig
+    type s = private < a : int; .. >
+    val eq : (s, < a : int; b : bool >) t
+  end
+Line _, characters 49-74:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Eq
+val f : (N.s, < a : int; b : bool >) t -> string = 
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr5989.ml.reference b/testsuite/tests/typing-gadts/pr5989.ml.reference
deleted file mode 100644
index f881c9b8..00000000
--- a/testsuite/tests/typing-gadts/pr5989.ml.reference
+++ /dev/null
@@ -1,24 +0,0 @@
-
-#       type (_, _) t = Any : ('a, 'b) t | Eq : ('a, 'a) t
-#                   module M : sig type s = private [> `A ] val eq : (s, [ `A | `B ]) t end
-#       Characters 40-65:
-  .......................................function
-    | Any -> "Any"
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Eq
-val f : (M.s, [ `A | `B ]) t -> string = 
-#   Exception: Match_failure ("//toplevel//", 14, 39).
-#                     module N :
-  sig
-    type s = private < a : int; .. >
-    val eq : (s, < a : int; b : bool >) t
-  end
-#       Characters 50-75:
-  .................................................function
-    | Any -> "Any"
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Eq
-val f : (N.s, < a : int; b : bool >) t -> string = 
-# 
diff --git a/testsuite/tests/typing-gadts/pr5997.ml b/testsuite/tests/typing-gadts/pr5997.ml
index 81eec137..1e293ef0 100644
--- a/testsuite/tests/typing-gadts/pr5997.ml
+++ b/testsuite/tests/typing-gadts/pr5997.ml
@@ -14,6 +14,16 @@ end = struct
 end;;
 
 match M.comp with | Diff -> false;;
+[%%expect{|
+type (_, _) comp = Eq : ('a, 'a) comp | Diff : ('a, 'b) comp
+module U : sig type t = T end
+module M : sig type t = T val comp : (U.t, t) comp end
+Line _, characters 0-33:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Eq
+Exception: Match_failure ("", 16, 0).
+|}];;
 
 module U = struct type t = {x : int} end;;
 
@@ -26,3 +36,12 @@ end = struct
 end;;
 
 match M.comp with | Diff -> false;;
+[%%expect{|
+module U : sig type t = { x : int; } end
+module M : sig type t = { x : int; } val comp : (U.t, t) comp end
+Line _, characters 0-33:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Eq
+Exception: Match_failure ("", 11, 0).
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr5997.ml.reference b/testsuite/tests/typing-gadts/pr5997.ml.reference
deleted file mode 100644
index 65af9f3b..00000000
--- a/testsuite/tests/typing-gadts/pr5997.ml.reference
+++ /dev/null
@@ -1,21 +0,0 @@
-
-#       type (_, _) comp = Eq : ('a, 'a) comp | Diff : ('a, 'b) comp
-#   module U : sig type t = T end
-#               module M : sig type t = T val comp : (U.t, t) comp end
-#   Characters 1-34:
-  match M.comp with | Diff -> false;;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Eq
-Exception: Match_failure ("//toplevel//", 13, 0).
-#   module U : sig type t = { x : int; } end
-#               module M : sig type t = { x : int; } val comp : (U.t, t) comp end
-#   Characters 1-34:
-  match M.comp with | Diff -> false;;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Eq
-Exception: Match_failure ("//toplevel//", 22, 0).
-# 
diff --git a/testsuite/tests/typing-gadts/pr6158.ml b/testsuite/tests/typing-gadts/pr6158.ml
index 752380cb..5a115b7b 100644
--- a/testsuite/tests/typing-gadts/pr6158.ml
+++ b/testsuite/tests/typing-gadts/pr6158.ml
@@ -7,3 +7,13 @@ let f : (int s, int t) eq -> unit = function Refl -> ();;
 
 module M (S : sig type 'a t = T of 'a type 'a s = T of 'a end) =
 struct let f : ('a S.s, 'a S.t) eq -> unit = function Refl -> () end;;
+[%%expect{|
+type 'a t = T of 'a
+type 'a s = S of 'a
+type (_, _) eq = Refl : ('a, 'a) eq
+Line _, characters 45-49:
+Error: This pattern matches values of type (int s, int s) eq
+       but a pattern was expected which matches values of type
+         (int s, int t) eq
+       Type int s is not compatible with type int t
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr6158.ml.principal.reference b/testsuite/tests/typing-gadts/pr6158.ml.principal.reference
deleted file mode 100644
index c022a461..00000000
--- a/testsuite/tests/typing-gadts/pr6158.ml.principal.reference
+++ /dev/null
@@ -1,19 +0,0 @@
-
-#       type 'a t = T of 'a
-type 'a s = S of 'a
-type (_, _) eq = Refl : ('a, 'a) eq
-#   Characters 46-50:
-  let f : (int s, int t) eq -> unit = function Refl -> ();;
-                                               ^^^^
-Error: This pattern matches values of type (int s, int s) eq
-       but a pattern was expected which matches values of type
-         (int s, int t) eq
-       Type int s is not compatible with type int t 
-#     Characters 120-124:
-  struct let f : ('a S.s, 'a S.t) eq -> unit = function Refl -> () end;;
-                                                        ^^^^
-Error: This pattern matches values of type ($0 S.s, $1 S.t) eq
-       but a pattern was expected which matches values of type
-         ('a S.s, 'a S.t) eq
-       The type constructor $0 would escape its scope
-# 
diff --git a/testsuite/tests/typing-gadts/pr6158.ml.reference b/testsuite/tests/typing-gadts/pr6158.ml.reference
deleted file mode 100644
index 692130f3..00000000
--- a/testsuite/tests/typing-gadts/pr6158.ml.reference
+++ /dev/null
@@ -1,19 +0,0 @@
-
-#       type 'a t = T of 'a
-type 'a s = S of 'a
-type (_, _) eq = Refl : ('a, 'a) eq
-#   Characters 46-50:
-  let f : (int s, int t) eq -> unit = function Refl -> ();;
-                                               ^^^^
-Error: This pattern matches values of type (int s, int s) eq
-       but a pattern was expected which matches values of type
-         (int s, int t) eq
-       Type int s is not compatible with type int t 
-#     Characters 120-124:
-  struct let f : ('a S.s, 'a S.t) eq -> unit = function Refl -> () end;;
-                                                        ^^^^
-Error: This pattern matches values of type ($'a S.s, $'a S.s) eq
-       but a pattern was expected which matches values of type
-         ($'a S.s, $'a S.t) eq
-       The type constructor $'a would escape its scope
-# 
diff --git a/testsuite/tests/typing-gadts/pr6163.ml b/testsuite/tests/typing-gadts/pr6163.ml
index dc5bb8c6..bfb644ad 100644
--- a/testsuite/tests/typing-gadts/pr6163.ml
+++ b/testsuite/tests/typing-gadts/pr6163.ml
@@ -13,3 +13,15 @@ let f (Aux x) =
   | Succ (Succ (Succ (Succ Zero))) -> "4"
   | _ -> .  (* error *)
 ;;
+[%%expect{|
+type _ nat = Zero : [ `Zero ] nat | Succ : 'a nat -> [ `Succ of 'a ] nat
+type 'a pre_nat = [ `Succ of 'a | `Zero ]
+type aux =
+    Aux :
+      [ `Succ of [< [< [< [ `Zero ] pre_nat ] pre_nat ] pre_nat ] ] nat ->
+      aux
+Line _, characters 4-5:
+Error: This match case could not be refuted.
+       Here is an example of a value that would reach it:
+       Succ (Succ (Succ (Succ (Succ Zero))))
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr6163.ml.principal.reference b/testsuite/tests/typing-gadts/pr6163.ml.principal.reference
deleted file mode 100644
index c1ac7bd1..00000000
--- a/testsuite/tests/typing-gadts/pr6163.ml.principal.reference
+++ /dev/null
@@ -1,14 +0,0 @@
-
-#     type _ nat = Zero : [ `Zero ] nat | Succ : 'a nat -> [ `Succ of 'a ] nat
-# type 'a pre_nat = [ `Succ of 'a | `Zero ]
-#   type aux =
-    Aux :
-      [ `Succ of [< [< [< [ `Zero ] pre_nat ] pre_nat ] pre_nat ] ] nat -> 
-      aux
-#                 Characters 162-163:
-    | _ -> .  (* error *)
-      ^
-Error: This match case could not be refuted.
-       Here is an example of a value that would reach it:
-       Succ (Succ (Succ (Succ (Succ Zero))))
-# 
diff --git a/testsuite/tests/typing-gadts/pr6163.ml.reference b/testsuite/tests/typing-gadts/pr6163.ml.reference
deleted file mode 100644
index c1ac7bd1..00000000
--- a/testsuite/tests/typing-gadts/pr6163.ml.reference
+++ /dev/null
@@ -1,14 +0,0 @@
-
-#     type _ nat = Zero : [ `Zero ] nat | Succ : 'a nat -> [ `Succ of 'a ] nat
-# type 'a pre_nat = [ `Succ of 'a | `Zero ]
-#   type aux =
-    Aux :
-      [ `Succ of [< [< [< [ `Zero ] pre_nat ] pre_nat ] pre_nat ] ] nat -> 
-      aux
-#                 Characters 162-163:
-    | _ -> .  (* error *)
-      ^
-Error: This match case could not be refuted.
-       Here is an example of a value that would reach it:
-       Succ (Succ (Succ (Succ (Succ Zero))))
-# 
diff --git a/testsuite/tests/typing-gadts/pr6174.ml b/testsuite/tests/typing-gadts/pr6174.ml
index 84f79ba0..fcf5c633 100644
--- a/testsuite/tests/typing-gadts/pr6174.ml
+++ b/testsuite/tests/typing-gadts/pr6174.ml
@@ -1,3 +1,9 @@
 type _ t = C : ((('a -> 'o) -> 'o) -> ('b -> 'o) -> 'o) t
 let f : type a o. ((a -> o) -> o) t -> (a -> o) -> o =
  fun C k -> k (fun x -> x);;
+[%%expect{|
+type _ t = C : ((('a -> 'o) -> 'o) -> ('b -> 'o) -> 'o) t
+Line _, characters 24-25:
+Error: This expression has type $0 but an expression was expected of type
+         $1 = ($2 -> $1) -> $1
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr6174.ml.principal.reference b/testsuite/tests/typing-gadts/pr6174.ml.principal.reference
deleted file mode 100644
index e47a32fa..00000000
--- a/testsuite/tests/typing-gadts/pr6174.ml.principal.reference
+++ /dev/null
@@ -1,7 +0,0 @@
-
-#     Characters 137-138:
-   fun C k -> k (fun x -> x);;
-                          ^
-Error: This expression has type $0 but an expression was expected of type
-         $1 = ($2 -> $1) -> $1
-# 
diff --git a/testsuite/tests/typing-gadts/pr6174.ml.reference b/testsuite/tests/typing-gadts/pr6174.ml.reference
deleted file mode 100644
index e47a32fa..00000000
--- a/testsuite/tests/typing-gadts/pr6174.ml.reference
+++ /dev/null
@@ -1,7 +0,0 @@
-
-#     Characters 137-138:
-   fun C k -> k (fun x -> x);;
-                          ^
-Error: This expression has type $0 but an expression was expected of type
-         $1 = ($2 -> $1) -> $1
-# 
diff --git a/testsuite/tests/typing-gadts/pr6241.ml b/testsuite/tests/typing-gadts/pr6241.ml
index 4034e4f8..ebda191c 100644
--- a/testsuite/tests/typing-gadts/pr6241.ml
+++ b/testsuite/tests/typing-gadts/pr6241.ml
@@ -14,3 +14,17 @@ module A = struct module type T = sig end end;;
 module N = M(A)(A);;
 
 let x = N.f A;;
+
+[%%expect{|
+type (_, _) t = A : ('a, 'a) t | B : string -> ('a, 'b) t
+Line _, characters 52-74:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+A
+module M :
+  functor (A : sig module type T end) (B : sig module type T end) ->
+    sig val f : ((module A.T), (module B.T)) t -> string end
+module A : sig module type T = sig  end end
+module N : sig val f : ((module A.T), (module A.T)) t -> string end
+Exception: Match_failure ("", 8, 52).
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr6241.ml.principal.reference b/testsuite/tests/typing-gadts/pr6241.ml.principal.reference
deleted file mode 100644
index cb3095a0..00000000
--- a/testsuite/tests/typing-gadts/pr6241.ml.principal.reference
+++ /dev/null
@@ -1,15 +0,0 @@
-
-#       type (_, _) t = A : ('a, 'a) t | B : string -> ('a, 'b) t
-#           Characters 127-149:
-  ....................................................function
-     | B s -> s
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-A
-module M :
-  functor (A : sig module type T end) (B : sig module type T end) ->
-    sig val f : ((module A.T), (module B.T)) t -> string end
-#   module A : sig module type T = sig  end end
-#   module N : sig val f : ((module A.T), (module A.T)) t -> string end
-#   Exception: Match_failure ("//toplevel//", 7, 52).
-# 
diff --git a/testsuite/tests/typing-gadts/pr6241.ml.reference b/testsuite/tests/typing-gadts/pr6241.ml.reference
deleted file mode 100644
index cb3095a0..00000000
--- a/testsuite/tests/typing-gadts/pr6241.ml.reference
+++ /dev/null
@@ -1,15 +0,0 @@
-
-#       type (_, _) t = A : ('a, 'a) t | B : string -> ('a, 'b) t
-#           Characters 127-149:
-  ....................................................function
-     | B s -> s
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-A
-module M :
-  functor (A : sig module type T end) (B : sig module type T end) ->
-    sig val f : ((module A.T), (module B.T)) t -> string end
-#   module A : sig module type T = sig  end end
-#   module N : sig val f : ((module A.T), (module A.T)) t -> string end
-#   Exception: Match_failure ("//toplevel//", 7, 52).
-# 
diff --git a/testsuite/tests/typing-gadts/pr6690.ml b/testsuite/tests/typing-gadts/pr6690.ml
index 151e9955..b9466f68 100644
--- a/testsuite/tests/typing-gadts/pr6690.ml
+++ b/testsuite/tests/typing-gadts/pr6690.ml
@@ -15,6 +15,32 @@ let vexpr (type visit_action)
   | Local -> fun _ -> raise Exit
   | Global -> fun _ -> raise Exit
 ;;
+[%%expect{|
+type 'a visit_action
+type insert
+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
+Line _, characters 4-9:
+Error: This pattern matches values of type
+         ($0, $0 * insert, $0 local_visit_action) context
+       but a pattern was expected which matches values of type
+         ($0, $0 * insert, visit_action) context
+       The type constructor $0 would escape its scope
+|}, Principal{|
+type 'a visit_action
+type insert
+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
+Line _, characters 4-10:
+Error: This pattern matches values of type ($1, $1, visit_action) context
+       but a pattern was expected which matches values of type
+         ($0, $0 * insert, visit_action) context
+       Type $1 is not compatible with type $0
+|}];;
 
 let vexpr (type visit_action)
     : ('a, 'result, visit_action) context -> 'a -> visit_action =
@@ -22,6 +48,20 @@ let vexpr (type visit_action)
   | Local -> fun _ -> raise Exit
   | Global -> fun _ -> raise Exit
 ;;
+[%%expect{|
+Line _, characters 4-9:
+Error: This pattern matches values of type
+         ($'a, $'a * insert, $'a local_visit_action) context
+       but a pattern was expected which matches values of type
+         ($'a, $'a * insert, visit_action) context
+       The type constructor $'a would escape its scope
+|}, Principal{|
+Line _, characters 4-10:
+Error: This pattern matches values of type ($1, $1, visit_action) context
+       but a pattern was expected which matches values of type
+         ($0, $0 * insert, visit_action) context
+       Type $1 is not compatible with type $0
+|}];;
 
 let vexpr (type result) (type visit_action)
     : (unit, result, visit_action) context -> unit -> visit_action =
@@ -29,3 +69,6 @@ let vexpr (type result) (type visit_action)
   | Local -> fun _ -> raise Exit
   | Global -> fun _ -> raise Exit
 ;;
+[%%expect{|
+val vexpr : (unit, 'a, 'b) context -> unit -> 'b = 
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr6690.ml.principal.reference b/testsuite/tests/typing-gadts/pr6690.ml.principal.reference
deleted file mode 100644
index 5c9215bf..00000000
--- a/testsuite/tests/typing-gadts/pr6690.ml.principal.reference
+++ /dev/null
@@ -1,23 +0,0 @@
-
-#                   type 'a visit_action
-type insert
-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 137-143:
-    | Global -> fun _ -> raise Exit
-      ^^^^^^
-Error: This pattern matches values of type ($1, $1, visit_action) context
-       but a pattern was expected which matches values of type
-         ($0, $0 * insert, visit_action) context
-       Type $1 is not compatible with type $0 
-#             Characters 145-151:
-    | Global -> fun _ -> raise Exit
-      ^^^^^^
-Error: This pattern matches values of type ($1, $1, visit_action) context
-       but a pattern was expected which matches values of type
-         ($0, $0 * insert, visit_action) context
-       Type $1 is not compatible with type $0 
-#             val vexpr : (unit, 'a, 'b) context -> unit -> 'b = 
-# 
diff --git a/testsuite/tests/typing-gadts/pr6690.ml.reference b/testsuite/tests/typing-gadts/pr6690.ml.reference
deleted file mode 100644
index ee67a095..00000000
--- a/testsuite/tests/typing-gadts/pr6690.ml.reference
+++ /dev/null
@@ -1,25 +0,0 @@
-
-#                   type 'a visit_action
-type insert
-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 104-109:
-    | Local -> fun _ -> raise Exit
-      ^^^^^
-Error: This pattern matches values of type
-         ($0, $0 * insert, $0 local_visit_action) context
-       but a pattern was expected which matches values of type
-         ($0, $0 * insert, visit_action) context
-       The type constructor $0 would escape its scope
-#             Characters 112-117:
-    | Local -> fun _ -> raise Exit
-      ^^^^^
-Error: This pattern matches values of type
-         ($'a, $'a * insert, $'a local_visit_action) context
-       but a pattern was expected which matches values of type
-         ($'a, $'a * insert, visit_action) context
-       The type constructor $'a would escape its scope
-#             val vexpr : (unit, 'a, 'b) context -> unit -> 'b = 
-# 
diff --git a/testsuite/tests/typing-gadts/pr6817.ml b/testsuite/tests/typing-gadts/pr6817.ml
index 73c1f635..c31f975b 100644
--- a/testsuite/tests/typing-gadts/pr6817.ml
+++ b/testsuite/tests/typing-gadts/pr6817.ml
@@ -22,3 +22,13 @@ let rec get_var : type stk ret. (stk s, ret) var -> stk lst -> ret = fun n s ->
   | Head, CCons (h, _) -> h
   | Tail n', CCons (_, t) -> get_var n' t
 ;;
+
+[%%expect{|
+module A : sig type nil = Cstr end
+type _ s = Nil : A.nil s | Cons : 't s -> ('h -> 't) s
+type ('stack, 'typ) var =
+    Head : (('typ -> 'a) s, 'typ) var
+  | Tail : ('tail s, 'typ) var -> (('b -> 'tail) s, 'typ) var
+type _ lst = CNil : A.nil lst | CCons : 'h * 't lst -> ('h -> 't) lst
+val get_var : ('stk s, 'ret) var -> 'stk lst -> 'ret = 
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr6817.ml.reference b/testsuite/tests/typing-gadts/pr6817.ml.reference
deleted file mode 100644
index ec47bcc9..00000000
--- a/testsuite/tests/typing-gadts/pr6817.ml.reference
+++ /dev/null
@@ -1,9 +0,0 @@
-
-#         module A : sig type nil = Cstr end
-#                         type _ s = Nil : A.nil s | Cons : 't s -> ('h -> 't) s
-type ('stack, 'typ) var =
-    Head : (('typ -> 'a) s, 'typ) var
-  | Tail : ('tail s, 'typ) var -> (('b -> 'tail) s, 'typ) var
-type _ lst = CNil : A.nil lst | CCons : 'h * 't lst -> ('h -> 't) lst
-#           val get_var : ('stk s, 'ret) var -> 'stk lst -> 'ret = 
-# 
diff --git a/testsuite/tests/typing-gadts/pr6980.ml b/testsuite/tests/typing-gadts/pr6980.ml
index 7538b25f..85b35d8f 100644
--- a/testsuite/tests/typing-gadts/pr6980.ml
+++ b/testsuite/tests/typing-gadts/pr6980.ml
@@ -9,3 +9,16 @@ type aux = Aux : 'a t second * ('a -> int) -> aux;;
 let it : 'a. [< `Bar | `Foo > `Bar ] as 'a = `Bar;;
 
 let g (Aux(Second, f)) = f it;;
+
+[%%expect{|
+type 'a t = 'a constraint 'a = [< `Bar | `Foo ]
+type 'a s = 'a constraint 'a = [< `Bar | `Baz | `Foo > `Bar ]
+type 'a first = First : 'b t second -> ([< `Bar | `Foo ] as 'b) t first
+and 'a second = Second : [< `Bar | `Baz | `Foo > `Bar ] s second
+type aux = Aux : ([< `Bar | `Foo ] as 'a) t second * ('a -> int) -> aux
+val it : [< `Bar | `Foo > `Bar ] = `Bar
+Line _, characters 27-29:
+Error: This expression has type [< `Bar | `Foo > `Bar ]
+       but an expression was expected of type [< `Bar | `Foo ]
+       Types for tag `Bar are incompatible
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr6980.ml.reference b/testsuite/tests/typing-gadts/pr6980.ml.reference
deleted file mode 100644
index 5fd89921..00000000
--- a/testsuite/tests/typing-gadts/pr6980.ml.reference
+++ /dev/null
@@ -1,14 +0,0 @@
-
-# type 'a t = 'a constraint 'a = [< `Bar | `Foo ]
-# type 'a s = 'a constraint 'a = [< `Bar | `Baz | `Foo > `Bar ]
-#     type 'a first = First : 'b t second -> ([< `Bar | `Foo ] as 'b) t first
-and 'a second = Second : [< `Bar | `Baz | `Foo > `Bar ] s second
-#   type aux = Aux : ([< `Bar | `Foo ] as 'a) t second * ('a -> int) -> aux
-#   val it : [< `Bar | `Foo > `Bar ] = `Bar
-#   Characters 28-30:
-  let g (Aux(Second, f)) = f it;;
-                             ^^
-Error: This expression has type [< `Bar | `Foo > `Bar ]
-       but an expression was expected of type [< `Bar | `Foo ]
-       Types for tag `Bar are incompatible
-# 
diff --git a/testsuite/tests/typing-gadts/pr6993_bad.ml b/testsuite/tests/typing-gadts/pr6993_bad.ml
index 122b50f3..65a312ba 100644
--- a/testsuite/tests/typing-gadts/pr6993_bad.ml
+++ b/testsuite/tests/typing-gadts/pr6993_bad.ml
@@ -10,3 +10,15 @@ and B : sig  type t val eq : (B.t list, t) eqp end =
   end;;
 
 f B.eq;;
+
+[%%expect{|
+type (_, _) eqp = Y : ('a, 'a) eqp | N : string -> ('a, 'b) eqp
+Line _, characters 36-66:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Y
+val f : ('a list, 'a) eqp -> unit = 
+module rec A : sig type t = B.t list end
+and B : sig type t val eq : (B.t list, t) eqp end
+Exception: Match_failure ("", 2, 36).
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr6993_bad.ml.reference b/testsuite/tests/typing-gadts/pr6993_bad.ml.reference
deleted file mode 100644
index cda1b16a..00000000
--- a/testsuite/tests/typing-gadts/pr6993_bad.ml.reference
+++ /dev/null
@@ -1,13 +0,0 @@
-
-#   Characters 100-130:
-  let f : ('a list, 'a) eqp -> unit = function N s -> print_string s;;
-                                      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Y
-type (_, _) eqp = Y : ('a, 'a) eqp | N : string -> ('a, 'b) eqp
-val f : ('a list, 'a) eqp -> unit = 
-#               module rec A : sig type t = B.t list end
-and B : sig type t val eq : (B.t list, t) eqp end
-#   Exception: Match_failure ("//toplevel//", 2, 36).
-# 
diff --git a/testsuite/tests/typing-gadts/pr7016.ml b/testsuite/tests/typing-gadts/pr7016.ml
index 2b2eefbb..2dff639e 100644
--- a/testsuite/tests/typing-gadts/pr7016.ml
+++ b/testsuite/tests/typing-gadts/pr7016.ml
@@ -3,7 +3,26 @@ type (_, _) t =
   | Cons : 'a * ('b, 'tl) t -> ('a * 'b, 'tl) t;;
 
 let get1 (Cons (x, _) : (_ * 'a, 'a) t) = x ;; (* warn, cf PR#6993 *)
+[%%expect{|
+type (_, _) t =
+    Nil : ('tl, 'tl) t
+  | Cons : 'a * ('b, 'tl) t -> ('a * 'b, 'tl) t
+Line _, characters 9-43:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Nil
+val get1 : ('b * 'a, 'a) t -> 'b = 
+|}];;
 
 let get1' = function
   | (Cons (x, _) : (_ * 'a, 'a) t) -> x
   | Nil -> assert false ;; (* ok *)
+[%%expect{|
+val get1' : ('b * 'a as 'a, 'a) t -> 'b = 
+|}, Principal{|
+Line _, characters 4-7:
+Error: This pattern matches values of type ('b * 'a, 'b * 'a) t
+       but a pattern was expected which matches values of type
+         ('b * 'a, 'a) t
+       The type variable 'a occurs inside 'b * 'a
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr7016.ml.reference b/testsuite/tests/typing-gadts/pr7016.ml.reference
deleted file mode 100644
index 1176287e..00000000
--- a/testsuite/tests/typing-gadts/pr7016.ml.reference
+++ /dev/null
@@ -1,13 +0,0 @@
-
-#     type (_, _) t =
-    Nil : ('tl, 'tl) t
-  | Cons : 'a * ('b, 'tl) t -> ('a * 'b, 'tl) t
-#   Characters 10-44:
-  let get1 (Cons (x, _) : (_ * 'a, 'a) t) = x ;; (* warn, cf PR#6993 *)
-           ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Nil
-val get1 : ('b * 'a, 'a) t -> 'b = 
-#       val get1' : ('b * 'a as 'a, 'a) t -> 'b = 
-# 
diff --git a/testsuite/tests/typing-gadts/pr7160.ml b/testsuite/tests/typing-gadts/pr7160.ml
index 91263dc0..38254892 100644
--- a/testsuite/tests/typing-gadts/pr7160.ml
+++ b/testsuite/tests/typing-gadts/pr7160.ml
@@ -3,3 +3,14 @@ type _ t =
 let rec f = function Int x -> x | Same s -> f s;;
 type 'a tt = 'a t =
   Int : int -> int tt | String : string -> string tt | Same : 'l1 t -> 'l2 tt;;
+
+[%%expect{|
+type _ t =
+    Int : int -> int t
+  | String : string -> string t
+  | Same : 'l t -> 'l t
+val f : int t -> int = 
+Line _, characters 0-97:
+Error: This variant or record definition does not match that of type 'a t
+       The types for field Same are not equal.
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr7160.ml.reference b/testsuite/tests/typing-gadts/pr7160.ml.reference
deleted file mode 100644
index 5d5e9254..00000000
--- a/testsuite/tests/typing-gadts/pr7160.ml.reference
+++ /dev/null
@@ -1,12 +0,0 @@
-
-#   type _ t =
-    Int : int -> int t
-  | String : string -> string t
-  | Same : 'l t -> 'l t
-# val f : int t -> int = 
-#   Characters 0-97:
-  type 'a tt = 'a t =
-    Int : int -> int tt | String : string -> string tt | Same : 'l1 t -> 'l2 tt..
-Error: This variant or record definition does not match that of type 'a t
-       The types for field Same are not equal.
-# 
diff --git a/testsuite/tests/typing-gadts/pr7214.ml b/testsuite/tests/typing-gadts/pr7214.ml
index ff077b4f..736b353e 100644
--- a/testsuite/tests/typing-gadts/pr7214.ml
+++ b/testsuite/tests/typing-gadts/pr7214.ml
@@ -6,3 +6,32 @@ let f (type a) (x : a t) =
     let x = (I : a t)
   end in
   () ;;
+[%%expect{|
+type _ t = I : int t
+Line _, characters 9-10:
+Error: This pattern matches values of type int t
+       but a pattern was expected which matches values of type a t
+       Type int is not compatible with type a
+|}];;
+
+(* extra example by Stephen Dolan, using recursive modules *)
+(* Should not be allowed! *)
+type (_,_) eq = Refl : ('a, 'a) eq;;
+
+let bad (type a) =
+ let module N = struct
+   module rec M : sig
+     val e : (int, a) eq
+   end = struct
+     let (Refl : (int, a) eq) = M.e  (* must fail for soundness *)
+     let e : (int, a) eq = Refl
+   end
+ end in N.M.e
+;;
+[%%expect{|
+type (_, _) eq = Refl : ('a, 'a) eq
+Line _, characters 10-14:
+Error: This pattern matches values of type (int, int) eq
+       but a pattern was expected which matches values of type (int, a) eq
+       Type int is not compatible with type a
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr7214.ml.reference b/testsuite/tests/typing-gadts/pr7214.ml.reference
deleted file mode 100644
index b0211233..00000000
--- a/testsuite/tests/typing-gadts/pr7214.ml.reference
+++ /dev/null
@@ -1,9 +0,0 @@
-
-# type _ t = I : int t
-#             Characters 61-62:
-      let (I : a t) = x     (* fail because of toplevel let *)
-           ^
-Error: This pattern matches values of type int t
-       but a pattern was expected which matches values of type a t
-       Type int is not compatible with type a 
-# 
diff --git a/testsuite/tests/typing-gadts/pr7222.ml b/testsuite/tests/typing-gadts/pr7222.ml
index 26b8a037..d26539de 100644
--- a/testsuite/tests/typing-gadts/pr7222.ml
+++ b/testsuite/tests/typing-gadts/pr7222.ml
@@ -8,3 +8,29 @@ type _ t = Nil : nil t | Cons : ('x, 'fx) elt * 'x t -> 'fx t;;
 let undetected: ('a -> 'b -> nil) t -> 'a n -> 'b n -> unit = fun sh i j ->
   let Cons(Elt dim, _) = sh in ()
 ;;
+
+[%%expect{|
+type +'a n = private int
+type nil = private Nil_type
+type (_, _) elt =
+    Elt_fine : 'nat n -> ('l, 'nat * 'l) elt
+  | Elt : 'nat n -> ('l, 'nat -> 'l) elt
+type _ t = Nil : nil t | Cons : ('x, 'fx) elt * 'x t -> 'fx t
+Line _, characters 11-18:
+Error: This pattern matches values of type ($Cons_'x, 'a -> $Cons_'x) elt
+       but a pattern was expected which matches values of type
+         ($Cons_'x, 'a -> $'b -> nil) elt
+       The type constructor $'b would escape its scope
+|}, Principal{|
+type +'a n = private int
+type nil = private Nil_type
+type (_, _) elt =
+    Elt_fine : 'nat n -> ('l, 'nat * 'l) elt
+  | Elt : 'nat n -> ('l, 'nat -> 'l) elt
+type _ t = Nil : nil t | Cons : ('x, 'fx) elt * 'x t -> 'fx t
+Line _, characters 6-22:
+Error: This pattern matches values of type ('a -> $0 -> nil) t
+       but a pattern was expected which matches values of type
+         ('a -> 'b -> nil) t
+       The type constructor $0 would escape its scope
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr7222.ml.principal.reference b/testsuite/tests/typing-gadts/pr7222.ml.principal.reference
deleted file mode 100644
index 3f28c3b2..00000000
--- a/testsuite/tests/typing-gadts/pr7222.ml.principal.reference
+++ /dev/null
@@ -1,15 +0,0 @@
-
-#           type +'a n = private int
-type nil = private Nil_type
-type (_, _) elt =
-    Elt_fine : 'nat n -> ('l, 'nat * 'l) elt
-  | Elt : 'nat n -> ('l, 'nat -> 'l) elt
-type _ t = Nil : nil t | Cons : ('x, 'fx) elt * 'x t -> 'fx t
-#       Characters 83-99:
-    let Cons(Elt dim, _) = sh in ()
-        ^^^^^^^^^^^^^^^^
-Error: This pattern matches values of type ('a -> $0 -> nil) t
-       but a pattern was expected which matches values of type
-         ('a -> 'b -> nil) t
-       The type constructor $0 would escape its scope
-# 
diff --git a/testsuite/tests/typing-gadts/pr7222.ml.reference b/testsuite/tests/typing-gadts/pr7222.ml.reference
deleted file mode 100644
index 15025953..00000000
--- a/testsuite/tests/typing-gadts/pr7222.ml.reference
+++ /dev/null
@@ -1,15 +0,0 @@
-
-#           type +'a n = private int
-type nil = private Nil_type
-type (_, _) elt =
-    Elt_fine : 'nat n -> ('l, 'nat * 'l) elt
-  | Elt : 'nat n -> ('l, 'nat -> 'l) elt
-type _ t = Nil : nil t | Cons : ('x, 'fx) elt * 'x t -> 'fx t
-#       Characters 88-95:
-    let Cons(Elt dim, _) = sh in ()
-             ^^^^^^^
-Error: This pattern matches values of type ($Cons_'x, 'a -> $Cons_'x) elt
-       but a pattern was expected which matches values of type
-         ($Cons_'x, 'a -> $'b -> nil) elt
-       The type constructor $'b would escape its scope
-# 
diff --git a/testsuite/tests/typing-gadts/pr7230.ml b/testsuite/tests/typing-gadts/pr7230.ml
index 6e588b64..16f652ce 100644
--- a/testsuite/tests/typing-gadts/pr7230.ml
+++ b/testsuite/tests/typing-gadts/pr7230.ml
@@ -2,3 +2,8 @@ type _ t = T : int t;;
 
 (* Should raise Not_found *)
 let _ = match (raise Not_found : float t) with _ -> .;;
+
+[%%expect{|
+type _ t = T : int t
+Exception: Not_found.
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr7230.ml.reference b/testsuite/tests/typing-gadts/pr7230.ml.reference
deleted file mode 100644
index a05bcdf1..00000000
--- a/testsuite/tests/typing-gadts/pr7230.ml.reference
+++ /dev/null
@@ -1,4 +0,0 @@
-
-# type _ t = T : int t
-#     Exception: Not_found.
-# 
diff --git a/testsuite/tests/typing-gadts/pr7234.ml b/testsuite/tests/typing-gadts/pr7234.ml
index a8a06d2a..622aef90 100644
--- a/testsuite/tests/typing-gadts/pr7234.ml
+++ b/testsuite/tests/typing-gadts/pr7234.ml
@@ -1,7 +1,24 @@
 type (_, _) eq = Eq : ('a, 'a) eq | Neq : int -> ('a, 'b) eq;;
 type 'a t;;
 let f (type a) (Neq n : (a, a t) eq) = n;;   (* warn! *)
+[%%expect{|
+type (_, _) eq = Eq : ('a, 'a) eq | Neq : int -> ('a, 'b) eq
+type 'a t
+Line _, characters 15-40:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Eq
+val f : ('a, 'a t) eq -> int = 
+|}];;
 
 module F (T : sig type _ t end) = struct
  let f (type a) (Neq n : (a, a T.t) eq) = n  (* warn! *)
 end;;
+[%%expect{|
+Line _, characters 16-43:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Eq
+module F :
+  functor (T : sig type _ t end) -> sig val f : ('a, 'a T.t) eq -> int end
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr7234.ml.principal.reference b/testsuite/tests/typing-gadts/pr7234.ml.principal.reference
deleted file mode 100644
index 6210e218..00000000
--- a/testsuite/tests/typing-gadts/pr7234.ml.principal.reference
+++ /dev/null
@@ -1,19 +0,0 @@
-
-# type (_, _) eq = Eq : ('a, 'a) eq | Neq : int -> ('a, 'b) eq
-# type 'a t
-# Characters 15-40:
-  let f (type a) (Neq n : (a, a t) eq) = n;;   (* warn! *)
-                 ^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Eq
-val f : ('a, 'a t) eq -> int = 
-#       Characters 58-85:
-   let f (type a) (Neq n : (a, a T.t) eq) = n  (* warn! *)
-                  ^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Eq
-module F :
-  functor (T : sig type _ t end) -> sig val f : ('a, 'a T.t) eq -> int end
-# 
diff --git a/testsuite/tests/typing-gadts/pr7234.ml.reference b/testsuite/tests/typing-gadts/pr7234.ml.reference
deleted file mode 100644
index 6210e218..00000000
--- a/testsuite/tests/typing-gadts/pr7234.ml.reference
+++ /dev/null
@@ -1,19 +0,0 @@
-
-# type (_, _) eq = Eq : ('a, 'a) eq | Neq : int -> ('a, 'b) eq
-# type 'a t
-# Characters 15-40:
-  let f (type a) (Neq n : (a, a t) eq) = n;;   (* warn! *)
-                 ^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Eq
-val f : ('a, 'a t) eq -> int = 
-#       Characters 58-85:
-   let f (type a) (Neq n : (a, a T.t) eq) = n  (* warn! *)
-                  ^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Eq
-module F :
-  functor (T : sig type _ t end) -> sig val f : ('a, 'a T.t) eq -> int end
-# 
diff --git a/testsuite/tests/typing-gadts/pr7260.ml b/testsuite/tests/typing-gadts/pr7260.ml
new file mode 100644
index 00000000..77daa1f2
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7260.ml
@@ -0,0 +1,21 @@
+type bar = < bar: unit >
+
+type _ ty = Int : int ty
+
+type dyn = Dyn : 'a ty -> dyn;;
+
+class foo =
+  object (this)
+    method foo (Dyn ty) =
+      match ty with
+      | Int -> (this :> bar)
+  end;;  (* fail, but not for scope *)
+
+[%%expect{|
+type bar = < bar : unit >
+type _ ty = Int : int ty
+type dyn = Dyn : 'a ty -> dyn
+Line _, characters 0-108:
+Error: This class should be virtual.
+       The following methods are undefined : bar
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr7269.ml b/testsuite/tests/typing-gadts/pr7269.ml
new file mode 100644
index 00000000..051b4dc5
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7269.ml
@@ -0,0 +1,71 @@
+type s = [`A | `B] and sub = [`B];;
+type +'a t = T : [< `Conj of 'a & sub | `Other of string] -> 'a t;; (* ok *)
+
+let f (T (`Other msg) : s t) = print_string msg;;
+let _ = f (T (`Conj `B) :> s t);; (* warn *)
+[%%expect{|
+type s = [ `A | `B ]
+and sub = [ `B ]
+type +'a t = T : [< `Conj of 'a & sub | `Other of string ] -> 'a t
+Line _, characters 6-47:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+T (`Conj _)
+val f : s t -> unit = 
+Exception: Match_failure ("", 4, 6).
+|}];;
+
+module M : sig
+  type s
+  type t = T : [< `Conj of int & s | `Other of string] -> t
+  val x : t
+end = struct
+  type s = int
+  type t = T : [< `Conj of int | `Other of string] -> t
+  let x = T (`Conj 42)
+end;;
+
+let () = M.(match x with T (`Other msg) -> print_string msg);; (* warn *)
+[%%expect{|
+module M :
+  sig
+    type s
+    type t = T : [< `Conj of int & s | `Other of string ] -> t
+    val x : t
+  end
+Line _, characters 12-59:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+T (`Conj _)
+Exception: Match_failure ("", 11, 12).
+|}];;
+
+
+module M : sig
+  type s
+  type elim =
+      { ex : 'a . ([<`Conj of int & s | `Other of string] as 'a) -> unit }
+  val e : elim -> unit
+end = struct
+  type s = int
+  type elim =
+      { ex : 'a . (([<`Conj of int | `Other of string] as 'a) -> unit) }
+  let e { ex } = ex (`Conj 42 : [`Conj of int])
+end;;
+
+let () = M.(e { ex = fun (`Other msg) -> print_string msg });; (* warn *)
+[%%expect{|
+module M :
+  sig
+    type s
+    type elim = {
+      ex : 'a. ([< `Conj of int & s | `Other of string ] as 'a) -> unit;
+    }
+    val e : elim -> unit
+  end
+Line _, characters 21-57:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+`Conj _
+Exception: Match_failure ("", 13, 21).
+|}];;
diff --git a/testsuite/tests/typing-gadts/pr7298.ml b/testsuite/tests/typing-gadts/pr7298.ml
new file mode 100644
index 00000000..695fc3c4
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7298.ml
@@ -0,0 +1,14 @@
+type t = T : t;;
+
+module M : sig
+  type free = < bar : t -> unit; foo : free -> unit >
+end = struct
+  class free = object (self : 'self)
+    method foo self = ()
+    method bar T = self#foo self
+  end
+end;;
+[%%expect{|
+type t = T : t
+module M : sig type free = < bar : t -> unit; foo : free -> unit > end
+|}]
diff --git a/testsuite/tests/typing-gadts/pr7374.ml b/testsuite/tests/typing-gadts/pr7374.ml
new file mode 100644
index 00000000..b7243fb3
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7374.ml
@@ -0,0 +1,49 @@
+type ('a, 'b) eq = Refl : ('a, 'a) eq
+
+module type S = sig
+  type 'a t constraint 'a = [`Rec of 'b]
+end;;
+[%%expect{|
+type ('a, 'b) eq = Refl : ('a, 'a) eq
+module type S = sig type 'a t constraint 'a = [ `Rec of 'b ] end
+|}]
+
+module Fix (X : S) : sig
+  type t
+  val uniq : ('a, [`Rec of 'a] X.t) eq -> ('a, t) eq
+end = struct
+  type t = [`Rec of 'a] X.t as 'a
+  let uniq : type a . (a, [`Rec of a] X.t) eq -> (a, t) eq =
+    fun Refl -> Refl
+end;; (* should fail *)
+[%%expect{|
+Line _, characters 16-20:
+Error: This expression has type (a, a) eq
+       but an expression was expected of type (a, t) eq
+       Type a is not compatible with type t = [ `Rec of 'a ] X.t as 'a
+|}]
+
+(* trigger segfault
+module Id = struct
+  type 'a t = 'b constraint 'a = [ `Rec of 'b ]
+end
+
+module Bad = Fix(Id)
+
+let segfault () =
+  print_endline (cast (trans (Bad.uniq Refl) (Bad.uniq Refl)) 0)
+*)
+
+(* addendum: ensure that hidden paths are checked too *)
+module F (X : sig type 'a t end) = struct
+  open X
+  let f : type a b. (a, b t) eq -> (b, a t) eq -> (a, a t t) eq =
+    fun Refl Refl -> Refl;;
+end;; (* should fail *)
+[%%expect{|
+Line _, characters 21-25:
+Error: This expression has type (a, a) eq
+       but an expression was expected of type (a, a X.t X.t) eq
+       Type a = b X.t is not compatible with type a X.t X.t
+       Type b is not compatible with type a X.t
+|}]
diff --git a/testsuite/tests/typing-gadts/pr7378.ml b/testsuite/tests/typing-gadts/pr7378.ml
new file mode 100644
index 00000000..3d8a2924
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7378.ml
@@ -0,0 +1,23 @@
+module X = struct
+  type t =
+    | A : 'a * 'b * ('a -> unit) -> t
+end;;
+[%%expect{|
+module X : sig type t = A : 'a * 'b * ('a -> unit) -> t end
+|}]
+
+module Y = struct
+  type t = X.t =
+    | A : 'a * 'b * ('b -> unit) -> t
+end;; (* should fail *)
+[%%expect{|
+Line _, characters 2-54:
+Error: This variant or record definition does not match that of type X.t
+       The types for field A are not equal.
+|}]
+
+(* would segfault
+let () =
+  match Y.A (1, "", print_string) with
+  | X.A (x, y, f) -> f x
+*)
diff --git a/testsuite/tests/typing-gadts/pr7381.ml b/testsuite/tests/typing-gadts/pr7381.ml
new file mode 100644
index 00000000..79cc245c
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7381.ml
@@ -0,0 +1,15 @@
+type (_,_) eql = Refl : ('a, 'a) eql;;
+[%%expect{|
+type (_, _) eql = Refl : ('a, 'a) eql
+|}]
+
+let f : type t. (int, t) eql * (t, string) eql -> unit = function _ -> . ;;
+[%%expect{|
+val f : (int, 't) eql * ('t, string) eql -> unit = 
+|}]
+
+let f : type t. ((int, t) eql * (t, string) eql) option -> unit =
+  function None -> () ;;
+[%%expect{|
+val f : ((int, 't) eql * ('t, string) eql) option -> unit = 
+|}]
diff --git a/testsuite/tests/typing-gadts/pr7390.ml b/testsuite/tests/typing-gadts/pr7390.ml
new file mode 100644
index 00000000..b421ec57
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7390.ml
@@ -0,0 +1,25 @@
+type empty = Empty and filled = Filled
+type ('a,'fout,'fin) opt =
+  | N : ('a, 'f, 'f) opt
+  | Y : 'a -> ('a, filled, empty) opt
+type 'fill either =
+  | Either : (string, 'fill, 'f) opt * (int, 'f, empty) opt -> 'fill either;;
+[%%expect{|
+type empty = Empty
+and filled = Filled
+type ('a, 'fout, 'fin) opt =
+    N : ('a, 'f, 'f) opt
+  | Y : 'a -> ('a, filled, empty) opt
+type 'fill either =
+    Either : (string, 'fill, 'f) opt * (int, 'f, empty) opt -> 'fill either
+|}]
+
+let f (* : filled either -> string *) =
+  fun (Either (Y a, N)) -> a;;
+[%%expect{|
+Line _, characters 2-28:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Either (N, Y _)
+val f : filled either -> string = 
+|}]
diff --git a/testsuite/tests/typing-gadts/pr7391.ml b/testsuite/tests/typing-gadts/pr7391.ml
new file mode 100644
index 00000000..ace84b5d
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7391.ml
@@ -0,0 +1,76 @@
+class virtual child1 parent =
+  object
+    method private parent = parent
+  end
+
+class virtual child2 =
+  object(_ : 'self)
+    constraint 'parent = < previous: 'self option; .. >
+    method private virtual parent: 'parent
+  end
+
+(* Worked in 4.03 *)
+let _ =
+  object(self)
+    method previous = None
+    method child =
+      object
+        inherit child1 self
+        inherit child2
+      end
+  end;;
+[%%expect{|
+class virtual child1 : 'a -> object method private parent : 'a end
+class virtual child2 :
+  object ('a)
+    method private virtual parent : < previous : 'a option; .. >
+  end
+- : < child : child2; previous : child2 option > = 
+|}]
+
+(* Worked in 4.03 *)
+let _ =
+  object(self)
+    method previous = None
+    method child (_ : unit) =
+      object
+        inherit child1 self
+        inherit child2
+      end
+  end;;
+[%%expect{|
+- : < child : unit -> child2; previous : child2 option > = 
+|}]
+
+(* Worked in 4.03 *)
+let _ =
+  object(self)
+    method previous = None
+    method child () =
+      object
+        inherit child1 self
+        inherit child2
+      end
+  end;;
+[%%expect{|
+- : < child : unit -> child2; previous : child2 option > = 
+|}]
+
+(* Didn't work in 4.03 *)
+let _ =
+  object(self)
+    method previous = None
+    method child =
+      let o =
+      object
+        inherit child1 self
+        inherit child2
+      end
+      in o
+  end;;
+[%%expect{|
+Line _, characters 16-22:
+Error: The method parent has type < child : 'a; previous : 'b option >
+       but is expected to have type < previous : < .. > option; .. >
+       Self type cannot escape its class
+|}]
diff --git a/testsuite/tests/typing-gadts/pr7397.ml b/testsuite/tests/typing-gadts/pr7397.ml
new file mode 100644
index 00000000..3960514b
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7397.ml
@@ -0,0 +1,25 @@
+type +'a t
+
+class type a = object
+ method b : b
+end
+
+and b = object
+ method a : a
+end
+
+type _ response =
+ | C : #a t response;;
+[%%expect{|
+type +'a t
+class type a = object method b : b end
+and b = object method a : a end
+type _ response = C : #a t response
+|}]
+
+let f (type a) (a : a response) =
+ match a with
+ | C -> 0;;
+[%%expect{|
+val f : 'a response -> int = 
+|}]
diff --git a/testsuite/tests/typing-gadts/term-conv.ml b/testsuite/tests/typing-gadts/term-conv.ml
index 9b53cd6e..4994bdfd 100644
--- a/testsuite/tests/typing-gadts/term-conv.ml
+++ b/testsuite/tests/typing-gadts/term-conv.ml
@@ -26,6 +26,21 @@ module Typeable = struct
   let gcast : type t t'. t ty -> t' ty -> t -> t' = fun t t' x ->
     match check_eq t t' with Eq -> x
 end;;
+[%%expect{|
+module Typeable :
+  sig
+    type 'a ty =
+        Int : int ty
+      | String : string ty
+      | List : 'a ty -> 'a list ty
+      | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
+      | Fun : ('a ty * 'b ty) -> ('a -> 'b) ty
+    type (_, _) eq = Eq : ('a, 'a) eq
+    exception CastFailure
+    val check_eq : 't ty -> 't' ty -> ('t, 't') eq
+    val gcast : 't ty -> 't' ty -> 't -> 't'
+  end
+|}];;
 
 module HOAS = struct
   open Typeable
@@ -42,6 +57,17 @@ module HOAS = struct
     | Lam (_, f) -> fun x -> intp (f (Con x))
     | App (f, a) -> intp f (intp a)
 end;;
+[%%expect{|
+module HOAS :
+  sig
+    type _ term =
+        Tag : 't Typeable.ty * int -> 't term
+      | Con : 't -> 't term
+      | Lam : 's Typeable.ty * ('s term -> 't term) -> ('s -> 't) term
+      | App : ('s -> 't) term * 's term -> 't term
+    val intp : 't term -> 't
+  end
+|}];;
 
 module DeBruijn = struct
   type ('env,'t) ix =
@@ -74,6 +100,25 @@ module DeBruijn = struct
     | Lam b  -> fun x -> intp b (Push (s, x))
     | App(f,a) -> intp f s (intp a s)
 end;;
+[%%expect{|
+module DeBruijn :
+  sig
+    type ('env, 't) ix =
+        ZeroIx : ('env * 't, 't) ix
+      | SuccIx : ('env, 't) ix -> ('env * 's, 't) ix
+    val to_int : ('env, 't) ix -> int
+    type ('env, 't) term =
+        Var : ('env, 't) ix -> ('env, 't) term
+      | Con : 't -> ('env, 't) term
+      | Lam : ('env * 's, 't) term -> ('env, 's -> 't) term
+      | App : ('env, 's -> 't) term * ('env, 's) term -> ('env, 't) term
+    type _ stack =
+        Empty : unit stack
+      | Push : 'env stack * 't -> ('env * 't) stack
+    val prj : ('env, 't) ix -> 'env stack -> 't
+    val intp : ('env, 't) term -> 'env stack -> 't
+  end
+|}];;
 
 module Convert = struct
   type (_,_) layout =
@@ -113,6 +158,21 @@ module Convert = struct
 
   let convert t = cvt EmptyLayout t
 end;;
+[%%expect{|
+module Convert :
+  sig
+    type (_, _) layout =
+        EmptyLayout : ('env, unit) layout
+      | PushLayout : 't Typeable.ty * ('env, 'env') layout *
+          ('env, 't) DeBruijn.ix -> ('env, 'env' * 't) layout
+    val size : ('env, 'env') layout -> int
+    val inc : ('env, 'env') layout -> ('env * 't, 'env') layout
+    val prj :
+      't Typeable.ty -> int -> ('env, 'env') layout -> ('env, 't) DeBruijn.ix
+    val cvt : ('env, 'env) layout -> 't HOAS.term -> ('env, 't) DeBruijn.term
+    val convert : 'a HOAS.term -> (unit, 'a) DeBruijn.term
+  end
+|}];;
 
 module Main = struct
   open HOAS
@@ -137,3 +197,22 @@ module Main = struct
   let plus_2_3' = convert (plus_2_3 Typeable.Int)
   let eval_plus_2_3' = DeBruijn.intp plus_2_3' DeBruijn.Empty succ 0
 end;;
+[%%expect{|
+module Main :
+  sig
+    val i : 'a Typeable.ty -> ('a -> 'a) HOAS.term
+    val zero : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val one : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val two : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val three : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val plus :
+      'a Typeable.ty ->
+      ((('a -> 'a) -> 'a -> 'a) ->
+       (('a -> 'a) -> 'a -> 'a) -> ('a -> 'a) -> 'a -> 'a)
+      HOAS.term
+    val plus_2_3 : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val i' : (unit, int -> int) DeBruijn.term
+    val plus_2_3' : (unit, (int -> int) -> int -> int) DeBruijn.term
+    val eval_plus_2_3' : int
+  end
+|}];;
diff --git a/testsuite/tests/typing-gadts/term-conv.ml.principal.reference b/testsuite/tests/typing-gadts/term-conv.ml.principal.reference
deleted file mode 100644
index cff10f16..00000000
--- a/testsuite/tests/typing-gadts/term-conv.ml.principal.reference
+++ /dev/null
@@ -1,71 +0,0 @@
-
-#                                                       module Typeable :
-  sig
-    type 'a ty =
-        Int : int ty
-      | String : string ty
-      | List : 'a ty -> 'a list ty
-      | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
-      | Fun : ('a ty * 'b ty) -> ('a -> 'b) ty
-    type (_, _) eq = Eq : ('a, 'a) eq
-    exception CastFailure
-    val check_eq : 't ty -> 't' ty -> ('t, 't') eq
-    val gcast : 't ty -> 't' ty -> 't -> 't'
-  end
-#                               module HOAS :
-  sig
-    type _ term =
-        Tag : 't Typeable.ty * int -> 't term
-      | Con : 't -> 't term
-      | Lam : 's Typeable.ty * ('s term -> 't term) -> ('s -> 't) term
-      | App : ('s -> 't) term * 's term -> 't term
-    val intp : 't term -> 't
-  end
-#                                                               module DeBruijn :
-  sig
-    type ('env, 't) ix =
-        ZeroIx : ('env * 't, 't) ix
-      | SuccIx : ('env, 't) ix -> ('env * 's, 't) ix
-    val to_int : ('env, 't) ix -> int
-    type ('env, 't) term =
-        Var : ('env, 't) ix -> ('env, 't) term
-      | Con : 't -> ('env, 't) term
-      | Lam : ('env * 's, 't) term -> ('env, 's -> 't) term
-      | App : ('env, 's -> 't) term * ('env, 's) term -> ('env, 't) term
-    type _ stack =
-        Empty : unit stack
-      | Push : 'env stack * 't -> ('env * 't) stack
-    val prj : ('env, 't) ix -> 'env stack -> 't
-    val intp : ('env, 't) term -> 'env stack -> 't
-  end
-#                                                                             module Convert :
-  sig
-    type (_, _) layout =
-        EmptyLayout : ('env, unit) layout
-      | PushLayout : 't Typeable.ty * ('env, 'env') layout *
-          ('env, 't) DeBruijn.ix -> ('env, 'env' * 't) layout
-    val size : ('env, 'env') layout -> int
-    val inc : ('env, 'env') layout -> ('env * 't, 'env') layout
-    val prj :
-      't Typeable.ty -> int -> ('env, 'env') layout -> ('env, 't) DeBruijn.ix
-    val cvt : ('env, 'env) layout -> 't HOAS.term -> ('env, 't) DeBruijn.term
-    val convert : 'a HOAS.term -> (unit, 'a) DeBruijn.term
-  end
-#                                               module Main :
-  sig
-    val i : 'a Typeable.ty -> ('a -> 'a) HOAS.term
-    val zero : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
-    val one : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
-    val two : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
-    val three : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
-    val plus :
-      'a Typeable.ty ->
-      ((('a -> 'a) -> 'a -> 'a) ->
-       (('a -> 'a) -> 'a -> 'a) -> ('a -> 'a) -> 'a -> 'a)
-      HOAS.term
-    val plus_2_3 : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
-    val i' : (unit, int -> int) DeBruijn.term
-    val plus_2_3' : (unit, (int -> int) -> int -> int) DeBruijn.term
-    val eval_plus_2_3' : int
-  end
-# 
diff --git a/testsuite/tests/typing-gadts/term-conv.ml.reference b/testsuite/tests/typing-gadts/term-conv.ml.reference
deleted file mode 100644
index cff10f16..00000000
--- a/testsuite/tests/typing-gadts/term-conv.ml.reference
+++ /dev/null
@@ -1,71 +0,0 @@
-
-#                                                       module Typeable :
-  sig
-    type 'a ty =
-        Int : int ty
-      | String : string ty
-      | List : 'a ty -> 'a list ty
-      | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
-      | Fun : ('a ty * 'b ty) -> ('a -> 'b) ty
-    type (_, _) eq = Eq : ('a, 'a) eq
-    exception CastFailure
-    val check_eq : 't ty -> 't' ty -> ('t, 't') eq
-    val gcast : 't ty -> 't' ty -> 't -> 't'
-  end
-#                               module HOAS :
-  sig
-    type _ term =
-        Tag : 't Typeable.ty * int -> 't term
-      | Con : 't -> 't term
-      | Lam : 's Typeable.ty * ('s term -> 't term) -> ('s -> 't) term
-      | App : ('s -> 't) term * 's term -> 't term
-    val intp : 't term -> 't
-  end
-#                                                               module DeBruijn :
-  sig
-    type ('env, 't) ix =
-        ZeroIx : ('env * 't, 't) ix
-      | SuccIx : ('env, 't) ix -> ('env * 's, 't) ix
-    val to_int : ('env, 't) ix -> int
-    type ('env, 't) term =
-        Var : ('env, 't) ix -> ('env, 't) term
-      | Con : 't -> ('env, 't) term
-      | Lam : ('env * 's, 't) term -> ('env, 's -> 't) term
-      | App : ('env, 's -> 't) term * ('env, 's) term -> ('env, 't) term
-    type _ stack =
-        Empty : unit stack
-      | Push : 'env stack * 't -> ('env * 't) stack
-    val prj : ('env, 't) ix -> 'env stack -> 't
-    val intp : ('env, 't) term -> 'env stack -> 't
-  end
-#                                                                             module Convert :
-  sig
-    type (_, _) layout =
-        EmptyLayout : ('env, unit) layout
-      | PushLayout : 't Typeable.ty * ('env, 'env') layout *
-          ('env, 't) DeBruijn.ix -> ('env, 'env' * 't) layout
-    val size : ('env, 'env') layout -> int
-    val inc : ('env, 'env') layout -> ('env * 't, 'env') layout
-    val prj :
-      't Typeable.ty -> int -> ('env, 'env') layout -> ('env, 't) DeBruijn.ix
-    val cvt : ('env, 'env) layout -> 't HOAS.term -> ('env, 't) DeBruijn.term
-    val convert : 'a HOAS.term -> (unit, 'a) DeBruijn.term
-  end
-#                                               module Main :
-  sig
-    val i : 'a Typeable.ty -> ('a -> 'a) HOAS.term
-    val zero : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
-    val one : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
-    val two : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
-    val three : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
-    val plus :
-      'a Typeable.ty ->
-      ((('a -> 'a) -> 'a -> 'a) ->
-       (('a -> 'a) -> 'a -> 'a) -> ('a -> 'a) -> 'a -> 'a)
-      HOAS.term
-    val plus_2_3 : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
-    val i' : (unit, int -> int) DeBruijn.term
-    val plus_2_3' : (unit, (int -> int) -> int -> int) DeBruijn.term
-    val eval_plus_2_3' : int
-  end
-# 
diff --git a/testsuite/tests/typing-gadts/test.ml b/testsuite/tests/typing-gadts/test.ml
index 61cfd39f..3003840f 100644
--- a/testsuite/tests/typing-gadts/test.ml
+++ b/testsuite/tests/typing-gadts/test.ml
@@ -27,6 +27,19 @@ module Exp =
       | Abs _ -> 5
   end
 ;;
+[%%expect{|
+module Exp :
+  sig
+    type _ t =
+        IntLit : int -> int t
+      | BoolLit : bool -> bool t
+      | Pair : 'a t * 'b t -> ('a * 'b) t
+      | App : ('a -> 'b) t * 'a t -> 'b t
+      | Abs : ('a -> 'b) -> ('a -> 'b) t
+    val eval : 's t -> 's
+    val discern : 'a t -> int
+  end
+|}];;
 
 module List =
   struct
@@ -46,6 +59,16 @@ module List =
         | Cons (a,b) -> length b
   end
 ;;
+[%%expect{|
+module List :
+  sig
+    type zero
+    type _ t = Nil : zero t | Cons : 'a * 'b t -> ('a * 'b) t
+    val head : ('a * 'b) t -> 'a
+    val tail : ('a * 'b) t -> 'b t
+    val length : 'a t -> int
+  end
+|}];;
 
 module Nonexhaustive =
   struct
@@ -75,6 +98,25 @@ module Nonexhaustive =
         | Bar _, Bar _ -> true
   end
 ;;
+[%%expect{|
+Line _, characters 6-34:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+C1 _
+Line _, characters 6-77:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(Bar _, Foo _)
+module Nonexhaustive :
+  sig
+    type 'a u = C1 : int -> int u | C2 : bool -> bool u
+    type 'a v = C1 : int -> int v
+    val unexhaustive : 's u -> 's
+    module M : sig type t type u end
+    type 'a t = Foo : M.t -> M.t t | Bar : M.u -> M.u t
+    val same_type : 's t * 's t -> bool
+  end
+|}];;
 
 module Exhaustive =
   struct
@@ -90,23 +132,63 @@ module Exhaustive =
         | Bar _, Bar _ -> true
   end
 ;;
+[%%expect{|
+module Exhaustive :
+  sig
+    type t = int
+    type u = bool
+    type 'a v = Foo : t -> t v | Bar : u -> u v
+    val same_type : 's v * 's v -> bool
+  end
+|}];;
 
 module PR6862 = struct
   class c (Some x) = object method x : int = x end
   type _ opt = Just : 'a -> 'a opt | Nothing : 'a opt
   class d (Just x) = object method x : int = x end
 end;;
+[%%expect{|
+Line _, characters 10-18:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+None
+Line _, characters 10-18:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Nothing
+module PR6862 :
+  sig
+    class c : int option -> object method x : int end
+    type _ opt = Just : 'a -> 'a opt | Nothing : 'a opt
+    class d : int opt -> object method x : int end
+  end
+|}];;
 
 module Exhaustive2 = struct
   type _ t = Int : int t
   let f (x : bool t option) = match x with None -> ()
 end;;
+[%%expect{|
+module Exhaustive2 :
+  sig type _ t = Int : int t val f : bool t option -> unit end
+|}];;
 
 module PR6220 = struct
   type 'a t = I : int t | F : float t
   let f : int t -> int = function I -> 1
-  let g : int t -> int = function I -> 1 | _ -> 2 (* no warning *)
+  let g : int t -> int = function I -> 1 | _ -> 2 (* warn *)
 end;;
+[%%expect{|
+Line _, characters 43-44:
+Warning 56: this match case is unreachable.
+Consider replacing it with a refutation case ' -> .'
+module PR6220 :
+  sig
+    type 'a t = I : int t | F : float t
+    val f : int t -> int
+    val g : int t -> int
+  end
+|}];;
 
 module PR6403 = struct
   type (_, _) eq = Refl : ('a, 'a) eq
@@ -116,6 +198,15 @@ module PR6403 = struct
   let notequal : ((int, bool) eq, empty) sum -> empty = function
     | Right empty -> empty
 end;;
+[%%expect{|
+module PR6403 :
+  sig
+    type (_, _) eq = Refl : ('a, 'a) eq
+    type empty = { bottom : 'a. 'a; }
+    type ('a, 'b) sum = Left of 'a | Right of 'b
+    val notequal : ((int, bool) eq, empty) sum -> empty
+  end
+|}];;
 
 module PR6437 = struct
   type ('a, 'b) ctx =
@@ -132,6 +223,16 @@ module PR6437 = struct
     | _ -> .
   (*| Nil, _ -> (assert false) *)  (* warns, but shouldn't *)
 end;;
+[%%expect{|
+module PR6437 :
+  sig
+    type ('a, 'b) ctx =
+        Nil : (unit, unit) ctx
+      | Cons : ('a, 'b) ctx -> ('a * unit, 'b * unit) ctx
+    type 'a var = O : ('a * unit) var | S : 'a var -> ('a * unit) var
+    val f : ('g1, 'g2) ctx * 'g1 var -> 'g2 var
+  end
+|}];;
 
 module PR6801 = struct
   type _ value =
@@ -143,6 +244,20 @@ module PR6801 = struct
     match x with
     | String s -> print_endline s (* warn : Any *)
 end;;
+[%%expect{|
+Line _, characters 4-50:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Any
+module PR6801 :
+  sig
+    type _ value =
+        String : string -> string value
+      | Float : float -> float value
+      | Any
+    val print_string_value : string value -> unit
+  end
+|}];;
 
 module Existential_escape =
   struct
@@ -151,6 +266,12 @@ module Existential_escape =
     let eval (D x) = x
   end
 ;;
+[%%expect{|
+Line _, characters 21-22:
+Error: This expression has type $D_'a t
+       but an expression was expected of type 'a
+       The type constructor $D_'a would escape its scope
+|}];;
 
 module Rectype =
   struct
@@ -159,6 +280,10 @@ module Rectype =
       fun C -> () (* here s = s*s! *)
   end
 ;;
+[%%expect{|
+module Rectype :
+  sig type (_, _) t = C : ('a, 'a) t val f : ('s, 's * 's) t -> unit end
+|}];;
 
 module Or_patterns =
   struct
@@ -172,6 +297,12 @@ module Or_patterns =
 
 end
 ;;
+[%%expect{|
+Line _, characters 11-19:
+Error: This pattern matches values of type int t
+       but a pattern was expected which matches values of type s t
+       Type int is not compatible with type s
+|}];;
 
 module Polymorphic_variants =
   struct
@@ -185,6 +316,13 @@ module Polymorphic_variants =
         | `A, BoolLit _ -> ()
   end
 ;;
+[%%expect{|
+module Polymorphic_variants :
+  sig
+    type _ t = IntLit : int -> int t | BoolLit : bool -> bool t
+    val eval : [ `A ] * 's t -> unit
+  end
+|}];;
 
 module Propagation = struct
   type _ t =
@@ -202,6 +340,16 @@ module Propagation = struct
     in r
 end
 ;;
+[%%expect{|
+module Propagation :
+  sig
+    type _ t = IntLit : int -> int t | BoolLit : bool -> bool t
+    val check : 's t -> 's
+  end
+|}, Principal{|
+Line _, characters 19-20:
+Error: This expression has type bool but an expression was expected of type s
+|}];;
 
 module Normal_constrs = struct
   type a = A
@@ -209,6 +357,15 @@ module Normal_constrs = struct
 
   let f = function A -> 1 | B -> 2
 end;;
+[%%expect{|
+Line _, characters 28-29:
+Error: This variant pattern is expected to have type a
+       The constructor B does not belong to type a
+|}, Principal{|
+Line _, characters 28-29:
+Error: This pattern matches values of type b
+       but a pattern was expected which matches values of type a
+|}];;
 
 module PR6849 = struct
   type 'a t = Foo : int t
@@ -216,6 +373,11 @@ module PR6849 = struct
   let f : int -> int = function
       Foo -> 5
 end;;
+[%%expect{|
+Line _, characters 6-9:
+Error: This pattern matches values of type 'a t
+       but a pattern was expected which matches values of type int
+|}];;
 
 type _ t = Int : int t ;;
 
@@ -224,67 +386,139 @@ let ky x y = ignore (x = y); x ;;
 let test : type a. a t -> a =
   function Int -> ky (1 : a) 1
 ;;
+[%%expect{|
+type _ t = Int : int t
+val ky : 'a -> 'a -> 'a = 
+val test : 'a t -> 'a = 
+|}];;
 
 let test : type a. a t -> _ =
   function Int -> 1       (* ok *)
 ;;
+[%%expect{|
+val test : 'a t -> int = 
+|}];;
 
 let test : type a. a t -> _ =
   function Int -> ky (1 : a) 1  (* fails *)
 ;;
+[%%expect{|
+Line _, characters 18-30:
+Error: This expression has type a = int
+       but an expression was expected of type 'a
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+|}];;
 
 let test : type a. a t -> a = fun x ->
   let r = match x with Int -> ky (1 : a) 1  (* fails *)
   in r
 ;;
+[%%expect{|
+Line _, characters 30-42:
+Error: This expression has type a = int
+       but an expression was expected of type 'a
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+|}];;
+
 let test : type a. a t -> a = fun x ->
   let r = match x with Int -> ky 1 (1 : a)  (* fails *)
   in r
 ;;
+[%%expect{|
+Line _, characters 30-42:
+Error: This expression has type a = int
+       but an expression was expected of type 'a
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+|}];;
+
 let test (type a) x =
   let r = match (x : a t) with Int -> ky 1 1
   in r
 ;;
+[%%expect{|
+val test : 'a t -> int = 
+|}];;
+
 let test : type a. a t -> a = fun x ->
   let r = match x with Int -> (1 : a)       (* ok! *)
   in r
 ;;
+[%%expect{|
+val test : 'a t -> 'a = 
+|}];;
+
 let test : type a. a t -> _ = fun x ->
   let r = match x with Int -> 1       (* ok! *)
   in r
 ;;
+[%%expect{|
+val test : 'a t -> int = 
+|}];;
+
 let test : type a. a t -> a = fun x ->
   let r : a = match x with Int -> 1
   in r (* ok *)
 ;;
+[%%expect{|
+val test : 'a t -> 'a = 
+|}];;
+
 let test2 : type a. a t -> a option = fun x ->
   let r = ref None in
   begin match x with Int -> r := Some (1 : a) end;
   !r (* ok *)
 ;;
+[%%expect{|
+val test2 : 'a t -> 'a option = 
+|}];;
+
 let test2 : type a. a t -> a option = fun x ->
   let r : a option ref = ref None in
   begin match x with Int -> r := Some 1 end;
   !r (* ok *)
 ;;
+[%%expect{|
+val test2 : 'a t -> 'a option = 
+|}];;
+
 let test2 : type a. a t -> a option = fun x ->
   let r : a option ref = ref None in
   let u = ref None in
   begin match x with Int -> r := Some 1; u := !r end;
   !u
 ;; (* ok (u non-ambiguous) *)
+[%%expect{|
+val test2 : 'a t -> 'a option = 
+|}];;
+
 let test2 : type a. a t -> a option = fun x ->
   let r : a option ref = ref None in
   let u = ref None in
   begin match x with Int -> u := Some 1; r := !u end;
   !u
 ;; (* fails because u : (int | a) option ref *)
+[%%expect{|
+Line _, characters 46-48:
+Error: This expression has type int option
+       but an expression was expected of type a option
+       Type int is not compatible with type a = int
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+|}];;
+
 let test2 : type a. a t -> a option = fun x ->
   let u = ref None in
   let r : a option ref = ref None in
   begin match x with Int -> r := Some 1; u := !r end;
   !u
 ;; (* ok *)
+[%%expect{|
+val test2 : 'a t -> 'a option = 
+|}];;
+
 let test2 : type a. a t -> a option = fun x ->
   let u = ref None in
   let a =
@@ -293,10 +527,22 @@ let test2 : type a. a t -> a option = fun x ->
     !u
   in a
 ;; (* ok *)
+[%%expect{|
+val test2 : 'a t -> 'a option = 
+|}];;
+
 let either = ky
 let we_y1x (type a) (x : a) (v : a t) =
   match v with Int -> let y = either 1 x in y
 ;; (* fail *)
+[%%expect{|
+val either : 'a -> 'a -> 'a = 
+Line _, characters 44-45:
+Error: This expression has type a = int
+       but an expression was expected of type 'a
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+|}];;
 
 (* Effect of external consraints *)
 let f (type a) (x : a t) y =
@@ -304,24 +550,43 @@ let f (type a) (x : a t) y =
   let r = match x with Int -> (y : a) in (* ok *)
   r
 ;;
+[%%expect{|
+val f : 'a t -> 'a -> 'a = 
+|}];;
+
 let f (type a) (x : a t) y =
   let r = match x with Int -> (y : a) in
   ignore (y : a); (* ok *)
   r
 ;;
+[%%expect{|
+val f : 'a t -> 'a -> 'a = 
+|}];;
+
 let f (type a) (x : a t) y =
   ignore (y : a);
   let r = match x with Int -> y in (* ok *)
   r
 ;;
+[%%expect{|
+val f : 'a t -> 'a -> 'a = 
+|}];;
+
 let f (type a) (x : a t) y =
   let r = match x with Int -> y in
   ignore (y : a); (* ok *)
   r
 ;;
+[%%expect{|
+val f : 'a t -> 'a -> 'a = 
+|}];;
+
 let f (type a) (x : a t) (y : a) =
   match x with Int -> y (* returns 'a *)
 ;;
+[%%expect{|
+val f : 'a t -> 'a -> 'a = 
+|}];;
 
 (* Combination with local modules *)
 
@@ -330,12 +595,22 @@ let f (type a) (x : a t) y =
     let module M = struct type b = a let z = (y : b) end
     in M.z
 ;; (* fails because of aliasing... *)
+[%%expect{|
+Line _, characters 46-47:
+Error: This expression has type a = int
+       but an expression was expected of type b = int
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+|}];;
 
 let f (type a) (x : a t) y =
   match x with Int ->
     let module M = struct type b = int let z = (y : b) end
     in M.z
 ;; (* ok *)
+[%%expect{|
+val f : 'a t -> int -> int = 
+|}];;
 
 (* Objects and variants *)
 
@@ -347,6 +622,11 @@ let f : type a. a h -> a = function
   | Has_m -> object method m = 1 end
   | Has_b -> object method b = true end
 ;;
+[%%expect{|
+type _ h = Has_m : < m : int > h | Has_b : < b : bool > h
+val f : 'a h -> 'a = 
+|}];;
+
 type _ j =
   | Has_A : [`A of int] j
   | Has_B : [`B of bool] j
@@ -355,23 +635,52 @@ let f : type a. a j -> a = function
   | Has_A -> `A 1
   | Has_B -> `B true
 ;;
+[%%expect{|
+type _ j = Has_A : [ `A of int ] j | Has_B : [ `B of bool ] j
+val f : 'a j -> 'a = 
+|}];;
 
 type (_,_) eq = Eq : ('a,'a) eq ;;
 
 let f : type a b. (a,b) eq -> ( as 'c) -> ( as 'c) =
   fun Eq o -> o
 ;; (* fail *)
+[%%expect{|
+type (_, _) eq = Eq : ('a, 'a) eq
+Line _, characters 4-90:
+Error: The universal type variable 'b cannot be generalized:
+       it is already bound to another variable.
+|}];;
 
 let f : type a b. (a,b) eq ->  ->  =
   fun Eq o -> o
 ;; (* fail *)
+[%%expect{|
+Line _, characters 14-15:
+Error: This expression has type < m : a; .. >
+       but an expression was expected of type < m : b; .. >
+       Type a is not compatible with type b = a
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+|}];;
 
 let f (type a) (type b) (eq : (a,b) eq) (o : ) :  =
   match eq with Eq -> o ;; (* should fail *)
+[%%expect{|
+Line _, characters 22-23:
+Error: This expression has type < m : a; .. >
+       but an expression was expected of type < m : b; .. >
+       Type a is not compatible with type b = a
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+|}];;
 
 let f : type a b. (a,b) eq ->  ->  =
   fun Eq o -> o
 ;; (* ok *)
+[%%expect{|
+val f : ('a, 'b) eq -> < m : 'a > -> < m : 'b > = 
+|}];;
 
 let int_of_bool : (bool,int) eq = Obj.magic Eq;;
 
@@ -381,46 +690,116 @@ let y = (x, f int_of_bool x);;
 let f : type a. (a, int) eq ->  -> bool =
   fun Eq o -> ignore (o : ); o#m = 3
 ;; (* should be ok *)
+[%%expect{|
+val int_of_bool : (bool, int) eq = Eq
+val x : < m : bool > = 
+val y : < m : bool > * < m : int > = (, )
+val f : ('a, int) eq -> < m : 'a > -> bool = 
+|}];;
 
 let f : type a b. (a,b) eq -> < m : a; .. > -> < m : b > =
   fun eq o ->
     ignore (o : < m : a >);
     let r : < m : b > = match eq with Eq -> o in (* fail with principal *)
     r;;
+[%%expect{|
+val f : ('a, 'b) eq -> < m : 'a > -> < m : 'b > = 
+|}, Principal{|
+Line _, characters 44-45:
+Error: This expression has type < m : a >
+       but an expression was expected of type < m : b >
+       Type a is not compatible with type b = a
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+|}];;
 
 let f : type a b. (a,b) eq -> < m : a; .. > -> < m : b > =
   fun eq o ->
     let r : < m : b > = match eq with Eq -> o in (* fail *)
     ignore (o : < m : a >);
     r;;
+[%%expect{|
+Line _, characters 44-45:
+Error: This expression has type < m : a; .. >
+       but an expression was expected of type < m : b >
+       Type a is not compatible with type b = a
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+|}];;
 
 let f : type a b. (a,b) eq -> [> `A of a] -> [> `A of b] =
   fun Eq o -> o ;; (* fail *)
+[%%expect{|
+Line _, characters 14-15:
+Error: This expression has type [> `A of a ]
+       but an expression was expected of type [> `A of b ]
+       Type a is not compatible with type b = a
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+|}];;
 
 let f (type a b) (eq : (a,b) eq) (v : [> `A of a]) : [> `A of b] =
   match eq with Eq -> v ;; (* should fail *)
+[%%expect{|
+Line _, characters 22-23:
+Error: This expression has type [> `A of a ]
+       but an expression was expected of type [> `A of b ]
+       Type a is not compatible with type b = a
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+|}];;
 
 let f : type a b. (a,b) eq -> [< `A of a | `B] -> [< `A of b | `B] =
   fun Eq o -> o ;; (* fail *)
+[%%expect{|
+Line _, characters 4-84:
+Error: This definition has type
+         ('a, 'b) eq -> ([< `A of 'b & 'a | `B ] as 'c) -> 'c
+       which is less general than 'a0 'b0. ('a0, 'b0) eq -> 'c -> 'c
+|}];;
 
 let f : type a b. (a,b) eq -> [`A of a | `B] -> [`A of b | `B] =
   fun Eq o -> o ;; (* ok *)
+[%%expect{|
+val f : ('a, 'b) eq -> [ `A of 'a | `B ] -> [ `A of 'b | `B ] = 
+|}];;
 
 let f : type a. (a, int) eq -> [`A of a] -> bool =
   fun Eq v -> match v with `A 1 -> true | _ -> false
 ;; (* ok *)
+[%%expect{|
+val f : ('a, int) eq -> [ `A of 'a ] -> bool = 
+|}];;
 
 let f : type a b. (a,b) eq -> [> `A of a | `B] -> [`A of b | `B] =
   fun eq o ->
     ignore (o : [< `A of a | `B]);
     let r : [`A of b | `B] = match eq with Eq -> o in (* fail with principal *)
     r;;
+[%%expect{|
+val f : ('a, 'b) eq -> [ `A of 'a | `B ] -> [ `A of 'b | `B ] = 
+|}, Principal{|
+Line _, characters 49-50:
+Error: This expression has type [ `A of a | `B ]
+       but an expression was expected of type [ `A of b | `B ]
+       Type a is not compatible with type b = a
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+|}];;
 
 let f : type a b. (a,b) eq -> [> `A of a | `B] -> [`A of b | `B] =
   fun eq o ->
     let r : [`A of b | `B] = match eq with Eq -> o in (* fail *)
     ignore (o : [< `A of a | `B]);
     r;;
+[%%expect{|
+Line _, characters 49-50:
+Error: This expression has type [> `A of a | `B ]
+       but an expression was expected of type [ `A of b | `B ]
+       Type a is not compatible with type b = a
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+|}];;
 
 (* Pattern matching *)
 
@@ -448,6 +827,16 @@ let f : type a. a ty -> a t -> int = fun x y ->
   | TC, D z -> truncate z
   | _, D _ -> 0
 ;;
+[%%expect{|
+type 'a t = A of int | B of bool | C of float | D of 'a
+type _ ty =
+    TE : 'a ty -> 'a array ty
+  | TA : int ty
+  | TB : bool ty
+  | TC : float ty
+  | TD : string -> bool ty
+val f : 'a ty -> 'a t -> int = 
+|}];;
 
 let f : type a. a ty -> a t -> int = fun x y ->
   match x, y with
@@ -458,6 +847,13 @@ let f : type a. a ty -> a t -> int = fun x y ->
   | TA, D 0 -> -1
   | TA, D z -> z
 ;; (* warn *)
+[%%expect{|
+Line _, characters 2-153:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(TE TC, D [| 0. |])
+val f : 'a ty -> 'a t -> int = 
+|}];;
 
 let f : type a. a ty -> a t -> int = fun x y ->
   match y, x with
@@ -468,6 +864,11 @@ let f : type a. a ty -> a t -> int = fun x y ->
   | D 0, TA -> -1
   | D z, TA -> z
 ;; (* fail *)
+[%%expect{|
+Line _, characters 6-13:
+Error: This pattern matches values of type 'a array
+       but a pattern was expected which matches values of type a
+|}];;
 
 type ('a,'b) pair = {right:'a; left:'b}
 
@@ -480,6 +881,12 @@ let f : type a. a ty -> a t -> int = fun x y ->
   | {left=TA; right=D 0} -> -1
   | {left=TA; right=D z} -> z
 ;; (* fail *)
+[%%expect{|
+type ('a, 'b) pair = { right : 'a; left : 'b; }
+Line _, characters 25-32:
+Error: This pattern matches values of type 'a array
+       but a pattern was expected which matches values of type a
+|}];;
 
 type ('a,'b) pair = {left:'a; right:'b}
 
@@ -492,6 +899,14 @@ let f : type a. a ty -> a t -> int = fun x y ->
   | {left=TA; right=D 0} -> -1
   | {left=TA; right=D z} -> z
 ;; (* ok *)
+[%%expect{|
+type ('a, 'b) pair = { left : 'a; right : 'b; }
+Line _, characters 2-244:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+{left=TE TC; right=D [| 0. |]}
+val f : 'a ty -> 'a t -> int = 
+|}];;
 
 (* Injectivity *)
 
@@ -502,14 +917,27 @@ module M : sig type 'a t val eq : ('a t, 'b t) eq end =
 let f : type a b. (a M.t, b M.t) eq -> (a, b) eq =
   function Eq -> Eq (* fail *)
 ;;
+[%%expect{|
+module M : sig type 'a t val eq : ('a t, 'b t) eq end
+Line _, characters 17-19:
+Error: This expression has type (a, a) eq
+       but an expression was expected of type (a, b) eq
+       Type a is not compatible with type b
+|}];;
 
 let f : type a b. (a M.t * a, b M.t * b) eq -> (a, b) eq =
   function Eq -> Eq (* ok *)
 ;;
+[%%expect{|
+val f : ('a M.t * 'a, 'b M.t * 'b) eq -> ('a, 'b) eq = 
+|}];;
 
 let f : type a b. (a * a M.t, b * b M.t) eq -> (a, b) eq =
   function Eq -> Eq (* ok *)
 ;;
+[%%expect{|
+val f : ('a * 'a M.t, 'b * 'b M.t) eq -> ('a, 'b) eq = 
+|}];;
 
 (* Applications of polymorphic variants *)
 
@@ -523,6 +951,11 @@ let f : type a. a t -> a = function
 ;;
 
 f V1;;
+[%%expect{|
+type _ t = V1 : [ `A | `B ] t | V2 : [ `C | `D ] t
+val f : 'a t -> 'a = 
+- : [ `A | `B ] = `A
+|}];;
 
 (* PR#5425 and PR#5427 *)
 
@@ -537,26 +970,54 @@ let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) =
   let IF_constr, IB_constr = e, e' in
   (x:)
 ;;
+[%%expect{|
+type _ int_foo = IF_constr : < foo : int; .. > int_foo
+type _ int_bar = IB_constr : < bar : int; .. > int_bar
+Line _, characters 3-4:
+Error: This expression has type t = < foo : int; .. >
+       but an expression was expected of type < foo : int >
+       Type $0 = < bar : int; .. > is not compatible with type <  >
+       The second object type has no method bar
+|}];;
 
 let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) =
   let IF_constr, IB_constr = e, e' in
   (x:)
 ;;
+[%%expect{|
+Line _, characters 3-4:
+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
+|}];;
 
 let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) =
   let IF_constr, IB_constr = e, e' in
   (x:)
 ;;
+[%%expect{|
+Line _, characters 2-26:
+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
+|}];;
 
 let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) : t =
   let IF_constr, IB_constr = e, e' in
   (x:)
 ;;
+[%%expect{|
+val g : 'a -> 'a int_foo -> 'a int_bar -> 'a = 
+|}];;
 
 let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) =
   let IF_constr, IB_constr = e, e' in
   x, x#foo, x#bar
 ;;
+[%%expect{|
+val g : 'a -> 'a int_foo -> 'a int_bar -> 'a * int * int = 
+|}];;
 
 (* PR#5554 *)
 
@@ -568,12 +1029,22 @@ let f : type a. a ty -> a =
 let g : type a. a ty -> a =
   let () = () in
   fun x -> match x with Int y -> y;;
+[%%expect{|
+type 'a ty = Int : int -> int ty
+val f : 'a ty -> 'a = 
+val g : 'a ty -> 'a = 
+|}];;
 
 (* Printing of anonymous variables *)
 
 module M = struct type _ t = int end;;
 module M = struct type _ t = T : int t end;;
 module N = M;;
+[%%expect{|
+module M : sig type _ t = int end
+module M : sig type _ t = T : int t end
+module N = M
+|}];;
 
 (* Principality *)
 
@@ -585,6 +1056,9 @@ let f : type a b. (a,b) eq -> (a,int) eq -> a -> b -> _ = fun ab aint a b ->
     if true then a else b
   in ignore x
 ;; (* ok *)
+[%%expect{|
+val f : ('a, 'b) eq -> ('a, int) eq -> 'a -> 'b -> unit = 
+|}];;
 
 let f : type a b. (a,b) eq -> (b,int) eq -> a -> b -> _ = fun ab bint a b ->
   let Eq = ab in
@@ -593,3 +1067,6 @@ let f : type a b. (a,b) eq -> (b,int) eq -> a -> b -> _ = fun ab bint a b ->
     if true then a else b
   in ignore x
 ;; (* ok *)
+[%%expect{|
+val f : ('a, 'b) eq -> ('b, int) eq -> 'a -> 'b -> unit = 
+|}];;
diff --git a/testsuite/tests/typing-gadts/test.ml.principal.reference b/testsuite/tests/typing-gadts/test.ml.principal.reference
deleted file mode 100644
index b69bb6b6..00000000
--- a/testsuite/tests/typing-gadts/test.ml.principal.reference
+++ /dev/null
@@ -1,379 +0,0 @@
-
-#                                                         module Exp :
-  sig
-    type _ t =
-        IntLit : int -> int t
-      | BoolLit : bool -> bool t
-      | Pair : 'a t * 'b t -> ('a * 'b) t
-      | App : ('a -> 'b) t * 'a t -> 'b t
-      | Abs : ('a -> 'b) -> ('a -> 'b) t
-    val eval : 's t -> 's
-    val discern : 'a t -> int
-  end
-#                                     module List :
-  sig
-    type zero
-    type _ t = Nil : zero t | Cons : 'a * 'b t -> ('a * 'b) t
-    val head : ('a * 'b) t -> 'a
-    val tail : ('a * 'b) t -> 'b t
-    val length : 'a t -> int
-  end
-#                                                         Characters 196-224:
-  ......function
-          | C2 x -> x
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-C1 _
-Characters 458-529:
-  ......function
-          | Foo _ , Foo _ -> true
-          | Bar _, Bar _ -> true
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(Bar _, Foo _)
-module Nonexhaustive :
-  sig
-    type 'a u = C1 : int -> int u | C2 : bool -> bool u
-    type 'a v = C1 : int -> int v
-    val unexhaustive : 's u -> 's
-    module M : sig type t type u end
-    type 'a t = Foo : M.t -> M.t t | Bar : M.u -> M.u t
-    val same_type : 's t * 's t -> bool
-  end
-#                             module Exhaustive :
-  sig
-    type t = int
-    type u = bool
-    type 'a v = Foo : t -> t v | Bar : u -> u v
-    val same_type : 's v * 's v -> bool
-  end
-#           Characters 34-42:
-    class c (Some x) = object method x : int = x end
-            ^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-None
-Characters 139-147:
-    class d (Just x) = object method x : int = x end
-            ^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Nothing
-module PR6862 :
-  sig
-    class c : int option -> object method x : int end
-    type _ opt = Just : 'a -> 'a opt | Nothing : 'a opt
-    class d : int opt -> object method x : int end
-  end
-#         module Exhaustive2 :
-  sig type _ t = Int : int t val f : bool t option -> unit end
-#           Characters 146-147:
-    let g : int t -> int = function I -> 1 | _ -> 2 (* no warning *)
-                                             ^
-Warning 56: this match case is unreachable.
-Consider replacing it with a refutation case ' -> .'
-module PR6220 :
-  sig
-    type 'a t = I : int t | F : float t
-    val f : int t -> int
-    val g : int t -> int
-  end
-#                 module PR6403 :
-  sig
-    type (_, _) eq = Refl : ('a, 'a) eq
-    type empty = { bottom : 'a. 'a; }
-    type ('a, 'b) sum = Left of 'a | Right of 'b
-    val notequal : ((int, bool) eq, empty) sum -> empty
-  end
-#                               module PR6437 :
-  sig
-    type ('a, 'b) ctx =
-        Nil : (unit, unit) ctx
-      | Cons : ('a, 'b) ctx -> ('a * unit, 'b * unit) ctx
-    type 'a var = O : ('a * unit) var | S : 'a var -> ('a * unit) var
-    val f : ('g1, 'g2) ctx * 'g1 var -> 'g2 var
-  end
-#                     Characters 175-221:
-  ....match x with
-      | String s -> print_endline s.................
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Any
-module PR6801 :
-  sig
-    type _ value =
-        String : string -> string value
-      | Float : float -> float value
-      | Any
-    val print_string_value : string value -> unit
-  end
-#               Characters 118-119:
-      let eval (D x) = x
-                       ^
-Error: This expression has type $D_'a t
-       but an expression was expected of type 'a
-       The type constructor $D_'a would escape its scope
-#               module Rectype :
-  sig type (_, _) t = C : ('a, 'a) t val f : ('s, 's * 's) t -> unit end
-#                         Characters 180-188:
-          | (IntLit _ | BoolLit _) -> ()
-             ^^^^^^^^
-Error: This pattern matches values of type int t
-       but a pattern was expected which matches values of type s t
-       Type int is not compatible with type s 
-#                         module Polymorphic_variants :
-  sig
-    type _ t = IntLit : int -> int t | BoolLit : bool -> bool t
-    val eval : [ `A ] * 's t -> unit
-  end
-#                                 Characters 299-300:
-      | BoolLit b -> b
-                     ^
-Error: This expression has type bool but an expression was expected of type s
-#             Characters 87-88:
-    let f = function A -> 1 | B -> 2
-                              ^
-Error: This pattern matches values of type b
-       but a pattern was expected which matches values of type a
-#             Characters 89-92:
-        Foo -> 5
-        ^^^
-Error: This pattern matches values of type 'a t
-       but a pattern was expected which matches values of type int
-#   type _ t = Int : int t
-#   val ky : 'a -> 'a -> 'a = 
-#       val test : 'a t -> 'a = 
-#       val test : 'a t -> int = 
-#       Characters 49-61:
-    function Int -> ky (1 : a) 1  (* fails *)
-                    ^^^^^^^^^^^^
-Error: This expression has type a = int
-       but an expression was expected of type 'a
-       This instance of int is ambiguous:
-       it would escape the scope of its equation
-#         Characters 70-82:
-    let r = match x with Int -> ky (1 : a) 1  (* fails *)
-                                ^^^^^^^^^^^^
-Error: This expression has type a = int
-       but an expression was expected of type 'a
-       This instance of int is ambiguous:
-       it would escape the scope of its equation
-#       Characters 69-81:
-    let r = match x with Int -> ky 1 (1 : a)  (* fails *)
-                                ^^^^^^^^^^^^
-Error: This expression has type a = int
-       but an expression was expected of type 'a
-       This instance of int is ambiguous:
-       it would escape the scope of its equation
-#       val test : 'a t -> int = 
-#       val test : 'a t -> 'a = 
-#       val test : 'a t -> int = 
-#       val test : 'a t -> 'a = 
-#         val test2 : 'a t -> 'a option = 
-#         val test2 : 'a t -> 'a option = 
-#           val test2 : 'a t -> 'a option = 
-#           Characters 152-154:
-    begin match x with Int -> u := Some 1; r := !u end;
-                                                ^^
-Error: This expression has type int option
-       but an expression was expected of type a option
-       Type int is not compatible with type a = int 
-       This instance of int is ambiguous:
-       it would escape the scope of its equation
-#           val test2 : 'a t -> 'a option = 
-#               val test2 : 'a t -> 'a option = 
-#       Characters 100-101:
-    match v with Int -> let y = either 1 x in y
-                                              ^
-Error: This expression has type a = int
-       but an expression was expected of type 'a
-       This instance of int is ambiguous:
-       it would escape the scope of its equation
-#             val f : 'a t -> 'a -> 'a = 
-#         val f : 'a t -> 'a -> 'a = 
-#         val f : 'a t -> 'a -> 'a = 
-#         val f : 'a t -> 'a -> 'a = 
-#     val f : 'a t -> 'a -> 'a = 
-#               Characters 136-137:
-      let module M = struct type b = a let z = (y : b) end
-                                                ^
-Error: This expression has type a = int
-       but an expression was expected of type b = int
-       This instance of int is ambiguous:
-       it would escape the scope of its equation
-#           val f : 'a t -> int -> int = 
-#                     type _ h = Has_m : < m : int > h | Has_b : < b : bool > h
-val f : 'a h -> 'a = 
-#               type _ j = Has_A : [ `A of int ] j | Has_B : [ `B of bool ] j
-val f : 'a j -> 'a = 
-#   type (_, _) eq = Eq : ('a, 'a) eq
-#       Characters 5-91:
-  ....f : type a b. (a,b) eq -> ( as 'c) -> ( as 'c) =
-    fun Eq o -> o
-Error: The universal type variable 'b cannot be generalized:
-       it is already bound to another variable.
-#       Characters 74-75:
-    fun Eq o -> o
-                ^
-Error: This expression has type < m : a; .. >
-       but an expression was expected of type < m : b; .. >
-       Type a is not compatible with type b = a 
-       This instance of a is ambiguous:
-       it would escape the scope of its equation
-#     Characters 97-98:
-    match eq with Eq -> o ;; (* should fail *)
-                        ^
-Error: This expression has type < m : a; .. >
-       but an expression was expected of type < m : b; .. >
-       Type a is not compatible with type b = a 
-       This instance of a is ambiguous:
-       it would escape the scope of its equation
-#       val f : ('a, 'b) eq -> < m : 'a > -> < m : 'b > = 
-#   val int_of_bool : (bool, int) eq = Eq
-#   val x : < m : bool > = 
-# val y : < m : bool > * < m : int > = (, )
-#       val f : ('a, int) eq -> < m : 'a > -> bool = 
-#           Characters 146-147:
-      let r : < m : b > = match eq with Eq -> o in (* fail with principal *)
-                                              ^
-Error: This expression has type < m : a >
-       but an expression was expected of type < m : b >
-       Type a is not compatible with type b = a 
-       This instance of a is ambiguous:
-       it would escape the scope of its equation
-#           Characters 118-119:
-      let r : < m : b > = match eq with Eq -> o in (* fail *)
-                                              ^
-Error: This expression has type < m : a; .. >
-       but an expression was expected of type < m : b >
-       Type a is not compatible with type b = a 
-       This instance of a is ambiguous:
-       it would escape the scope of its equation
-#     Characters 74-75:
-    fun Eq o -> o ;; (* fail *)
-                ^
-Error: This expression has type [> `A of a ]
-       but an expression was expected of type [> `A of b ]
-       Type a is not compatible with type b = a 
-       This instance of a is ambiguous:
-       it would escape the scope of its equation
-#     Characters 90-91:
-    match eq with Eq -> v ;; (* should fail *)
-                        ^
-Error: This expression has type [> `A of a ]
-       but an expression was expected of type [> `A of b ]
-       Type a is not compatible with type b = a 
-       This instance of a is ambiguous:
-       it would escape the scope of its equation
-#     Characters 5-85:
-  ....f : type a b. (a,b) eq -> [< `A of a | `B] -> [< `A of b | `B] =
-    fun Eq o -> o..............
-Error: This definition has type
-         ('a, 'b) eq -> ([< `A of 'b & 'a | `B ] as 'c) -> 'c
-       which is less general than 'a0 'b0. ('a0, 'b0) eq -> 'c -> 'c
-#     val f : ('a, 'b) eq -> [ `A of 'a | `B ] -> [ `A of 'b | `B ] = 
-#       val f : ('a, int) eq -> [ `A of 'a ] -> bool = 
-#           Characters 166-167:
-      let r : [`A of b | `B] = match eq with Eq -> o in (* fail with principal *)
-                                                   ^
-Error: This expression has type [ `A of a | `B ]
-       but an expression was expected of type [ `A of b | `B ]
-       Type a is not compatible with type b = a 
-       This instance of a is ambiguous:
-       it would escape the scope of its equation
-#           Characters 131-132:
-      let r : [`A of b | `B] = match eq with Eq -> o in (* fail *)
-                                                   ^
-Error: This expression has type [> `A of a | `B ]
-       but an expression was expected of type [ `A of b | `B ]
-       Type a is not compatible with type b = a 
-       This instance of a is ambiguous:
-       it would escape the scope of its equation
-#                                                     type 'a t = A of int | B of bool | C of float | D of 'a
-type _ ty =
-    TE : 'a ty -> 'a array ty
-  | TA : int ty
-  | TB : bool ty
-  | TC : float ty
-  | TD : string -> bool ty
-val f : 'a ty -> 'a t -> int = 
-#                   Characters 51-202:
-  ..match x, y with
-    | _, A z -> z
-    | _, B z -> if z then 1 else 2
-    | _, C z -> truncate z
-    | TE TC, D [|1.0|] -> 14
-    | TA, D 0 -> -1
-    | TA, D z -> z
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(TE TC, D [| 0. |])
-val f : 'a ty -> 'a t -> int = 
-#                   Characters 147-154:
-    | D [|1.0|], TE TC -> 14
-        ^^^^^^^
-Error: This pattern matches values of type 'a array
-       but a pattern was expected which matches values of type a
-#                       Characters 259-266:
-    | {left=TE TC; right=D [|1.0|]} -> 14
-                           ^^^^^^^
-Error: This pattern matches values of type 'a array
-       but a pattern was expected which matches values of type a
-#                       Characters 92-334:
-  ..match {left=x; right=y} with
-    | {left=_; right=A z} -> z
-    | {left=_; right=B z} -> if z then 1 else 2
-    | {left=_; right=C z} -> truncate z
-    | {left=TE TC; right=D [|1.0|]} -> 14
-    | {left=TA; right=D 0} -> -1
-    | {left=TA; right=D z} -> z
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-{left=TE TC; right=D [| 0. |]}
-type ('a, 'b) pair = { left : 'a; right : 'b; }
-val f : 'a ty -> 'a t -> int = 
-#           module M : sig type 'a t val eq : ('a t, 'b t) eq end
-#       Characters 69-71:
-    function Eq -> Eq (* fail *)
-                   ^^
-Error: This expression has type (a, a) eq
-       but an expression was expected of type (a, b) eq
-       Type a is not compatible with type b 
-#       val f : ('a M.t * 'a, 'b M.t * 'b) eq -> ('a, 'b) eq = 
-#       val f : ('a * 'a M.t, 'b * 'b M.t) eq -> ('a, 'b) eq = 
-#                     type _ t = V1 : [ `A | `B ] t | V2 : [ `C | `D ] t
-val f : 'a t -> 'a = 
-#   - : [ `A | `B ] = `A
-#                 type _ int_foo = IF_constr : < foo : int; .. > int_foo
-type _ int_bar = IB_constr : < bar : int; .. > int_bar
-#         Characters 98-99:
-    (x:)
-     ^
-Error: This expression has type t = < foo : int; .. >
-       but an expression was expected of type < foo : int >
-       Type $0 = < bar : int; .. > is not compatible with type <  > 
-       The second object type has no method bar
-#         Characters 98-99:
-    (x:)
-     ^
-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 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
-#         val g : 'a -> 'a int_foo -> 'a int_bar -> 'a = 
-#         val g : 'a -> 'a int_foo -> 'a int_bar -> 'a * int * int = 
-#       type 'a ty = Int : int -> int ty
-#     val f : 'a ty -> 'a = 
-#       val g : 'a ty -> 'a = 
-#       module M : sig type _ t = int end
-# module M : sig type _ t = T : int t end
-# module N = M
-#                     val f : ('a, 'b) eq -> ('a, int) eq -> 'a -> 'b -> unit = 
-#               val f : ('a, 'b) eq -> ('b, int) eq -> 'a -> 'b -> unit = 
-# 
diff --git a/testsuite/tests/typing-gadts/test.ml.reference b/testsuite/tests/typing-gadts/test.ml.reference
deleted file mode 100644
index 2ef37155..00000000
--- a/testsuite/tests/typing-gadts/test.ml.reference
+++ /dev/null
@@ -1,366 +0,0 @@
-
-#                                                         module Exp :
-  sig
-    type _ t =
-        IntLit : int -> int t
-      | BoolLit : bool -> bool t
-      | Pair : 'a t * 'b t -> ('a * 'b) t
-      | App : ('a -> 'b) t * 'a t -> 'b t
-      | Abs : ('a -> 'b) -> ('a -> 'b) t
-    val eval : 's t -> 's
-    val discern : 'a t -> int
-  end
-#                                     module List :
-  sig
-    type zero
-    type _ t = Nil : zero t | Cons : 'a * 'b t -> ('a * 'b) t
-    val head : ('a * 'b) t -> 'a
-    val tail : ('a * 'b) t -> 'b t
-    val length : 'a t -> int
-  end
-#                                                         Characters 196-224:
-  ......function
-          | C2 x -> x
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-C1 _
-Characters 458-529:
-  ......function
-          | Foo _ , Foo _ -> true
-          | Bar _, Bar _ -> true
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(Bar _, Foo _)
-module Nonexhaustive :
-  sig
-    type 'a u = C1 : int -> int u | C2 : bool -> bool u
-    type 'a v = C1 : int -> int v
-    val unexhaustive : 's u -> 's
-    module M : sig type t type u end
-    type 'a t = Foo : M.t -> M.t t | Bar : M.u -> M.u t
-    val same_type : 's t * 's t -> bool
-  end
-#                             module Exhaustive :
-  sig
-    type t = int
-    type u = bool
-    type 'a v = Foo : t -> t v | Bar : u -> u v
-    val same_type : 's v * 's v -> bool
-  end
-#           Characters 34-42:
-    class c (Some x) = object method x : int = x end
-            ^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-None
-Characters 139-147:
-    class d (Just x) = object method x : int = x end
-            ^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Nothing
-module PR6862 :
-  sig
-    class c : int option -> object method x : int end
-    type _ opt = Just : 'a -> 'a opt | Nothing : 'a opt
-    class d : int opt -> object method x : int end
-  end
-#         module Exhaustive2 :
-  sig type _ t = Int : int t val f : bool t option -> unit end
-#           Characters 146-147:
-    let g : int t -> int = function I -> 1 | _ -> 2 (* no warning *)
-                                             ^
-Warning 56: this match case is unreachable.
-Consider replacing it with a refutation case ' -> .'
-module PR6220 :
-  sig
-    type 'a t = I : int t | F : float t
-    val f : int t -> int
-    val g : int t -> int
-  end
-#                 module PR6403 :
-  sig
-    type (_, _) eq = Refl : ('a, 'a) eq
-    type empty = { bottom : 'a. 'a; }
-    type ('a, 'b) sum = Left of 'a | Right of 'b
-    val notequal : ((int, bool) eq, empty) sum -> empty
-  end
-#                               module PR6437 :
-  sig
-    type ('a, 'b) ctx =
-        Nil : (unit, unit) ctx
-      | Cons : ('a, 'b) ctx -> ('a * unit, 'b * unit) ctx
-    type 'a var = O : ('a * unit) var | S : 'a var -> ('a * unit) var
-    val f : ('g1, 'g2) ctx * 'g1 var -> 'g2 var
-  end
-#                     Characters 175-221:
-  ....match x with
-      | String s -> print_endline s.................
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Any
-module PR6801 :
-  sig
-    type _ value =
-        String : string -> string value
-      | Float : float -> float value
-      | Any
-    val print_string_value : string value -> unit
-  end
-#               Characters 118-119:
-      let eval (D x) = x
-                       ^
-Error: This expression has type $D_'a t
-       but an expression was expected of type 'a
-       The type constructor $D_'a would escape its scope
-#               module Rectype :
-  sig type (_, _) t = C : ('a, 'a) t val f : ('s, 's * 's) t -> unit end
-#                         Characters 180-188:
-          | (IntLit _ | BoolLit _) -> ()
-             ^^^^^^^^
-Error: This pattern matches values of type int t
-       but a pattern was expected which matches values of type s t
-       Type int is not compatible with type s 
-#                         module Polymorphic_variants :
-  sig
-    type _ t = IntLit : int -> int t | BoolLit : bool -> bool t
-    val eval : [ `A ] * 's t -> unit
-  end
-#                                 module Propagation :
-  sig
-    type _ t = IntLit : int -> int t | BoolLit : bool -> bool t
-    val check : 's t -> 's
-  end
-#             Characters 87-88:
-    let f = function A -> 1 | B -> 2
-                              ^
-Error: This variant pattern is expected to have type a
-       The constructor B does not belong to type a
-#             Characters 89-92:
-        Foo -> 5
-        ^^^
-Error: This pattern matches values of type 'a t
-       but a pattern was expected which matches values of type int
-#   type _ t = Int : int t
-#   val ky : 'a -> 'a -> 'a = 
-#       val test : 'a t -> 'a = 
-#       val test : 'a t -> int = 
-#       Characters 49-61:
-    function Int -> ky (1 : a) 1  (* fails *)
-                    ^^^^^^^^^^^^
-Error: This expression has type a = int
-       but an expression was expected of type 'a
-       This instance of int is ambiguous:
-       it would escape the scope of its equation
-#         Characters 70-82:
-    let r = match x with Int -> ky (1 : a) 1  (* fails *)
-                                ^^^^^^^^^^^^
-Error: This expression has type a = int
-       but an expression was expected of type 'a
-       This instance of int is ambiguous:
-       it would escape the scope of its equation
-#       Characters 69-81:
-    let r = match x with Int -> ky 1 (1 : a)  (* fails *)
-                                ^^^^^^^^^^^^
-Error: This expression has type a = int
-       but an expression was expected of type 'a
-       This instance of int is ambiguous:
-       it would escape the scope of its equation
-#       val test : 'a t -> int = 
-#       val test : 'a t -> 'a = 
-#       val test : 'a t -> int = 
-#       val test : 'a t -> 'a = 
-#         val test2 : 'a t -> 'a option = 
-#         val test2 : 'a t -> 'a option = 
-#           val test2 : 'a t -> 'a option = 
-#           Characters 152-154:
-    begin match x with Int -> u := Some 1; r := !u end;
-                                                ^^
-Error: This expression has type int option
-       but an expression was expected of type a option
-       Type int is not compatible with type a = int 
-       This instance of int is ambiguous:
-       it would escape the scope of its equation
-#           val test2 : 'a t -> 'a option = 
-#               val test2 : 'a t -> 'a option = 
-#       Characters 100-101:
-    match v with Int -> let y = either 1 x in y
-                                              ^
-Error: This expression has type a = int
-       but an expression was expected of type 'a
-       This instance of int is ambiguous:
-       it would escape the scope of its equation
-#             val f : 'a t -> 'a -> 'a = 
-#         val f : 'a t -> 'a -> 'a = 
-#         val f : 'a t -> 'a -> 'a = 
-#         val f : 'a t -> 'a -> 'a = 
-#     val f : 'a t -> 'a -> 'a = 
-#               Characters 136-137:
-      let module M = struct type b = a let z = (y : b) end
-                                                ^
-Error: This expression has type a = int
-       but an expression was expected of type b = int
-       This instance of int is ambiguous:
-       it would escape the scope of its equation
-#           val f : 'a t -> int -> int = 
-#                     type _ h = Has_m : < m : int > h | Has_b : < b : bool > h
-val f : 'a h -> 'a = 
-#               type _ j = Has_A : [ `A of int ] j | Has_B : [ `B of bool ] j
-val f : 'a j -> 'a = 
-#   type (_, _) eq = Eq : ('a, 'a) eq
-#       Characters 5-91:
-  ....f : type a b. (a,b) eq -> ( as 'c) -> ( as 'c) =
-    fun Eq o -> o
-Error: The universal type variable 'b cannot be generalized:
-       it is already bound to another variable.
-#       Characters 74-75:
-    fun Eq o -> o
-                ^
-Error: This expression has type < m : a; .. >
-       but an expression was expected of type < m : b; .. >
-       Type a is not compatible with type b = a 
-       This instance of a is ambiguous:
-       it would escape the scope of its equation
-#     Characters 97-98:
-    match eq with Eq -> o ;; (* should fail *)
-                        ^
-Error: This expression has type < m : a; .. >
-       but an expression was expected of type < m : b; .. >
-       Type a is not compatible with type b = a 
-       This instance of a is ambiguous:
-       it would escape the scope of its equation
-#       val f : ('a, 'b) eq -> < m : 'a > -> < m : 'b > = 
-#   val int_of_bool : (bool, int) eq = Eq
-#   val x : < m : bool > = 
-# val y : < m : bool > * < m : int > = (, )
-#       val f : ('a, int) eq -> < m : 'a > -> bool = 
-#           val f : ('a, 'b) eq -> < m : 'a > -> < m : 'b > = 
-#           Characters 118-119:
-      let r : < m : b > = match eq with Eq -> o in (* fail *)
-                                              ^
-Error: This expression has type < m : a; .. >
-       but an expression was expected of type < m : b >
-       Type a is not compatible with type b = a 
-       This instance of a is ambiguous:
-       it would escape the scope of its equation
-#     Characters 74-75:
-    fun Eq o -> o ;; (* fail *)
-                ^
-Error: This expression has type [> `A of a ]
-       but an expression was expected of type [> `A of b ]
-       Type a is not compatible with type b = a 
-       This instance of a is ambiguous:
-       it would escape the scope of its equation
-#     Characters 90-91:
-    match eq with Eq -> v ;; (* should fail *)
-                        ^
-Error: This expression has type [> `A of a ]
-       but an expression was expected of type [> `A of b ]
-       Type a is not compatible with type b = a 
-       This instance of a is ambiguous:
-       it would escape the scope of its equation
-#     Characters 5-85:
-  ....f : type a b. (a,b) eq -> [< `A of a | `B] -> [< `A of b | `B] =
-    fun Eq o -> o..............
-Error: This definition has type
-         ('a, 'b) eq -> ([< `A of 'b & 'a | `B ] as 'c) -> 'c
-       which is less general than 'a0 'b0. ('a0, 'b0) eq -> 'c -> 'c
-#     val f : ('a, 'b) eq -> [ `A of 'a | `B ] -> [ `A of 'b | `B ] = 
-#       val f : ('a, int) eq -> [ `A of 'a ] -> bool = 
-#           val f : ('a, 'b) eq -> [ `A of 'a | `B ] -> [ `A of 'b | `B ] = 
-#           Characters 131-132:
-      let r : [`A of b | `B] = match eq with Eq -> o in (* fail *)
-                                                   ^
-Error: This expression has type [> `A of a | `B ]
-       but an expression was expected of type [ `A of b | `B ]
-       Type a is not compatible with type b = a 
-       This instance of a is ambiguous:
-       it would escape the scope of its equation
-#                                                     type 'a t = A of int | B of bool | C of float | D of 'a
-type _ ty =
-    TE : 'a ty -> 'a array ty
-  | TA : int ty
-  | TB : bool ty
-  | TC : float ty
-  | TD : string -> bool ty
-val f : 'a ty -> 'a t -> int = 
-#                   Characters 51-202:
-  ..match x, y with
-    | _, A z -> z
-    | _, B z -> if z then 1 else 2
-    | _, C z -> truncate z
-    | TE TC, D [|1.0|] -> 14
-    | TA, D 0 -> -1
-    | TA, D z -> z
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(TE TC, D [| 0. |])
-val f : 'a ty -> 'a t -> int = 
-#                   Characters 147-154:
-    | D [|1.0|], TE TC -> 14
-        ^^^^^^^
-Error: This pattern matches values of type 'a array
-       but a pattern was expected which matches values of type a
-#                       Characters 259-266:
-    | {left=TE TC; right=D [|1.0|]} -> 14
-                           ^^^^^^^
-Error: This pattern matches values of type 'a array
-       but a pattern was expected which matches values of type a
-#                       Characters 92-334:
-  ..match {left=x; right=y} with
-    | {left=_; right=A z} -> z
-    | {left=_; right=B z} -> if z then 1 else 2
-    | {left=_; right=C z} -> truncate z
-    | {left=TE TC; right=D [|1.0|]} -> 14
-    | {left=TA; right=D 0} -> -1
-    | {left=TA; right=D z} -> z
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-{left=TE TC; right=D [| 0. |]}
-type ('a, 'b) pair = { left : 'a; right : 'b; }
-val f : 'a ty -> 'a t -> int = 
-#           module M : sig type 'a t val eq : ('a t, 'b t) eq end
-#       Characters 69-71:
-    function Eq -> Eq (* fail *)
-                   ^^
-Error: This expression has type (a, a) eq
-       but an expression was expected of type (a, b) eq
-       Type a is not compatible with type b 
-#       val f : ('a M.t * 'a, 'b M.t * 'b) eq -> ('a, 'b) eq = 
-#       val f : ('a * 'a M.t, 'b * 'b M.t) eq -> ('a, 'b) eq = 
-#                     type _ t = V1 : [ `A | `B ] t | V2 : [ `C | `D ] t
-val f : 'a t -> 'a = 
-#   - : [ `A | `B ] = `A
-#                 type _ int_foo = IF_constr : < foo : int; .. > int_foo
-type _ int_bar = IB_constr : < bar : int; .. > int_bar
-#         Characters 98-99:
-    (x:)
-     ^
-Error: This expression has type t = < foo : int; .. >
-       but an expression was expected of type < foo : int >
-       Type $0 = < bar : int; .. > is not compatible with type <  > 
-       The second object type has no method bar
-#         Characters 98-99:
-    (x:)
-     ^
-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 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
-#         val g : 'a -> 'a int_foo -> 'a int_bar -> 'a = 
-#         val g : 'a -> 'a int_foo -> 'a int_bar -> 'a * int * int = 
-#       type 'a ty = Int : int -> int ty
-#     val f : 'a ty -> 'a = 
-#       val g : 'a ty -> 'a = 
-#       module M : sig type _ t = int end
-# module M : sig type _ t = T : int t end
-# module N = M
-#                     val f : ('a, 'b) eq -> ('a, int) eq -> 'a -> 'b -> unit = 
-#               val f : ('a, 'b) eq -> ('b, int) eq -> 'a -> 'b -> unit = 
-# 
diff --git a/testsuite/tests/typing-gadts/unify_mb.ml b/testsuite/tests/typing-gadts/unify_mb.ml
index 89f69211..f11f92cc 100644
--- a/testsuite/tests/typing-gadts/unify_mb.ml
+++ b/testsuite/tests/typing-gadts/unify_mb.ml
@@ -29,6 +29,14 @@ let fin_succ : type n. n fin -> n is_succ = function
   | FZ -> IS
   | FS _ -> IS
 ;;
+[%%expect{|
+type zero = Zero
+type _ succ = Succ
+type _ nat = NZ : zero nat | NS : 'a nat -> 'a succ nat
+type _ fin = FZ : 'a succ fin | FS : 'a fin -> 'a succ fin
+type _ is_succ = IS : 'a succ is_succ
+val fin_succ : 'n fin -> 'n is_succ = 
+|}];;
 
 (* 3 First-Order Terms, Renaming and Substitution *)
 
@@ -50,6 +58,14 @@ let comp_subst f g (x : 'a fin) = pre_subst f (g x)
 (*  val comp_subst :
     ('b fin -> 'c term) -> ('a fin -> 'b term) -> 'a fin -> 'c term *)
 ;;
+[%%expect{|
+type 'a term = Var of 'a fin | Leaf | Fork of 'a term * 'a term
+val var : 'a fin -> 'a term = 
+val lift : ('m fin -> 'n fin) -> 'm fin -> 'n term = 
+val pre_subst : ('a fin -> 'b term) -> 'a term -> 'b term = 
+val comp_subst :
+  ('b fin -> 'c term) -> ('a fin -> 'b term) -> 'a fin -> 'c term = 
+|}];;
 
 (* 4 The Occur-Check, through thick and thin *)
 
@@ -58,12 +74,18 @@ let rec thin : type n. n succ fin -> n fin -> n succ fin =
   | FZ, y    -> FS y
   | FS x, FZ -> FZ
   | FS x, FS y -> FS (thin x y)
+[%%expect{|
+val thin : 'n succ fin -> 'n fin -> 'n succ fin = 
+|}];;
 
 let bind t f =
   match t with
   | None   -> None
   | Some x -> f x
 (* val bind : 'a option -> ('a -> 'b option) -> 'b option *)
+[%%expect{|
+val bind : 'a option -> ('a -> 'b option) -> 'b option = 
+|}];;
 
 let rec thick : type n. n succ fin -> n succ fin -> n fin option =
   fun x y -> match x, y with
@@ -72,6 +94,9 @@ let rec thick : type n. n succ fin -> n succ fin -> n fin option =
   | FS x, FZ -> let IS = fin_succ x in Some FZ
   | FS x, FS y ->
       let IS = fin_succ x in bind (thick x y) (fun x -> Some (FS x))
+[%%expect{|
+val thick : 'n succ fin -> 'n succ fin -> 'n fin option = 
+|}];;
 
 let rec check : type n. n succ fin -> n succ term -> n term option =
   fun x t -> match t with
@@ -80,16 +105,25 @@ let rec check : type n. n succ fin -> n succ term -> n term option =
   | Fork (t1, t2) ->
       bind (check x t1) (fun t1 ->
         bind (check x t2) (fun t2 -> Some (Fork (t1, t2))))
+[%%expect{|
+val check : 'n succ fin -> 'n succ term -> 'n term option = 
+|}];;
 
 let subst_var x t' y =
   match thick x y with
   | None -> t'
   | Some y' -> Var y'
 (* val subst_var : 'a succ fin -> 'a term -> 'a succ fin -> 'a term *)
+[%%expect{|
+val subst_var : 'a succ fin -> 'a term -> 'a succ fin -> 'a term = 
+|}];;
 
 let subst x t' = pre_subst (subst_var x t')
 (* val subst : 'a succ fin -> 'a term -> 'a succ term -> 'a term *)
 ;;
+[%%expect{|
+val subst : 'a succ fin -> 'a term -> 'a succ term -> 'a term = 
+|}];;
 
 (* 5 A Refinement of Substitution *)
 
@@ -100,15 +134,29 @@ type (_,_) alist =
 let rec sub : type m n. (m,n) alist -> m fin -> n term = function
   | Anil -> var
   | Asnoc (s, t, x) -> comp_subst (sub s) (subst_var x t)
+[%%expect{|
+type (_, _) alist =
+    Anil : ('n, 'n) alist
+  | Asnoc : ('m, 'n) alist * 'm term * 'm succ fin -> ('m succ, 'n) alist
+val sub : ('m, 'n) alist -> 'm fin -> 'n term = 
+|}];;
 
 let rec append : type m n l. (m,n) alist -> (l,m) alist -> (l,n) alist =
   fun r s -> match s with
   | Anil -> r
   | Asnoc (s, t, x) -> Asnoc (append r s, t, x)
+[%%expect{|
+val append : ('m, 'n) alist -> ('l, 'm) alist -> ('l, 'n) alist = 
+|}];;
 
 type _ ealist = EAlist : ('a,'b) alist -> 'a ealist
 
 let asnoc a t' x = EAlist (Asnoc (a, t', x))
+[%%expect{|
+type _ ealist = EAlist : ('a, 'b) alist -> 'a ealist
+val asnoc : ('a, 'b) alist -> 'a term -> 'a succ fin -> 'a succ ealist =
+  
+|}];;
 
 (* Extra work: we need sub to work on ealist too, for examples *)
 let rec weaken_fin : type n. n fin -> n succ fin = function
@@ -131,6 +179,13 @@ let rec sub' : type m. m ealist -> m fin -> m term = function
 let subst' d = pre_subst (sub' d)
 (*  val subst' : 'a ealist -> 'a term -> 'a term *)
 ;;
+[%%expect{|
+val weaken_fin : 'n fin -> 'n succ fin = 
+val weaken_term : 'a term -> 'a succ term = 
+val weaken_alist : ('m, 'n) alist -> ('m succ, 'n succ) alist = 
+val sub' : 'm ealist -> 'm fin -> 'm term = 
+val subst' : 'a ealist -> 'a term -> 'a term = 
+|}];;
 
 (* 6 First-Order Unification *)
 
@@ -161,6 +216,12 @@ let rec amgu : type m. m term -> m term -> m ealist -> m ealist option =
 let mgu s t = amgu s t (EAlist Anil)
 (* val mgu : 'a term -> 'a term -> 'a ealist option *)
 ;;
+[%%expect{|
+val flex_flex : 'a succ fin -> 'a succ fin -> 'a succ ealist = 
+val flex_rigid : 'a succ fin -> 'a succ term -> 'a succ ealist option = 
+val amgu : 'm term -> 'm term -> 'm ealist -> 'm ealist option = 
+val mgu : 'a term -> 'a term -> 'a ealist option = 
+|}];;
 
 let s = Fork (Var FZ, Fork (Var (FS (FS FZ)), Leaf))
 let t = Fork (Var (FS FZ), Var (FS FZ))
@@ -168,3 +229,13 @@ let d = match mgu s t with Some x -> x | None -> failwith "mgu"
 let s' = subst' d s
 let t' = subst' d t
 ;;
+[%%expect{|
+val s : 'a succ succ succ term = Fork (Var FZ, Fork (Var (FS (FS FZ)), Leaf))
+val t : 'a succ succ term = Fork (Var (FS FZ), Var (FS FZ))
+val d : '_a succ succ succ ealist =
+  EAlist (Asnoc (Asnoc (Anil, Fork (Var FZ, Leaf), FZ), Var FZ, FZ))
+val s' : '_a succ succ succ term =
+  Fork (Fork (Var FZ, Leaf), Fork (Var FZ, Leaf))
+val t' : '_a succ succ succ term =
+  Fork (Fork (Var FZ, Leaf), Fork (Var FZ, Leaf))
+|}];;
diff --git a/testsuite/tests/typing-gadts/unify_mb.ml.principal.reference b/testsuite/tests/typing-gadts/unify_mb.ml.principal.reference
deleted file mode 100644
index 90e69dc0..00000000
--- a/testsuite/tests/typing-gadts/unify_mb.ml.principal.reference
+++ /dev/null
@@ -1,45 +0,0 @@
-
-#                                       * * *                 type zero = Zero
-type _ succ = Succ
-type _ nat = NZ : zero nat | NS : 'a nat -> 'a succ nat
-type _ fin = FZ : 'a succ fin | FS : 'a fin -> 'a succ fin
-type _ is_succ = IS : 'a succ is_succ
-val fin_succ : 'n fin -> 'n is_succ = 
-#                                     *   type 'a term = Var of 'a fin | Leaf | Fork of 'a term * 'a term
-val var : 'a fin -> 'a term = 
-val lift : ('m fin -> 'n fin) -> 'm fin -> 'n term = 
-val pre_subst : ('a fin -> 'b term) -> 'a term -> 'b term = 
-val comp_subst :
-  ('b fin -> 'c term) -> ('a fin -> 'b term) -> 'a fin -> 'c term = 
-#                                                                               val thin : 'n succ fin -> 'n fin -> 'n succ fin = 
-val bind : 'a option -> ('a -> 'b option) -> 'b option = 
-val thick : 'n succ fin -> 'n succ fin -> 'n fin option = 
-val check : 'n succ fin -> 'n succ term -> 'n term option = 
-val subst_var : 'a succ fin -> 'a term -> 'a succ fin -> 'a term = 
-val subst : 'a succ fin -> 'a term -> 'a succ term -> 'a term = 
-#                                                                                 type (_, _) alist =
-    Anil : ('n, 'n) alist
-  | Asnoc : ('m, 'n) alist * 'm term * 'm succ fin -> ('m succ, 'n) alist
-val sub : ('m, 'n) alist -> 'm fin -> 'n term = 
-val append : ('m, 'n) alist -> ('l, 'm) alist -> ('l, 'n) alist = 
-type _ ealist = EAlist : ('a, 'b) alist -> 'a ealist
-val asnoc : ('a, 'b) alist -> 'a term -> 'a succ fin -> 'a succ ealist =
-  
-val weaken_fin : 'n fin -> 'n succ fin = 
-val weaken_term : 'a term -> 'a succ term = 
-val weaken_alist : ('m, 'n) alist -> ('m succ, 'n succ) alist = 
-val sub' : 'm ealist -> 'm fin -> 'm term = 
-val subst' : 'a ealist -> 'a term -> 'a term = 
-#                                                           val flex_flex : 'a succ fin -> 'a succ fin -> 'a succ ealist = 
-val flex_rigid : 'a succ fin -> 'a succ term -> 'a succ ealist option = 
-val amgu : 'm term -> 'm term -> 'm ealist -> 'm ealist option = 
-val mgu : 'a term -> 'a term -> 'a ealist option = 
-#             val s : 'a succ succ succ term = Fork (Var FZ, Fork (Var (FS (FS FZ)), Leaf))
-val t : 'a succ succ term = Fork (Var (FS FZ), Var (FS FZ))
-val d : '_a succ succ succ ealist =
-  EAlist (Asnoc (Asnoc (Anil, Fork (Var FZ, Leaf), FZ), Var FZ, FZ))
-val s' : '_a succ succ succ term =
-  Fork (Fork (Var FZ, Leaf), Fork (Var FZ, Leaf))
-val t' : '_a succ succ succ term =
-  Fork (Fork (Var FZ, Leaf), Fork (Var FZ, Leaf))
-# 
diff --git a/testsuite/tests/typing-gadts/unify_mb.ml.reference b/testsuite/tests/typing-gadts/unify_mb.ml.reference
deleted file mode 100644
index 90e69dc0..00000000
--- a/testsuite/tests/typing-gadts/unify_mb.ml.reference
+++ /dev/null
@@ -1,45 +0,0 @@
-
-#                                       * * *                 type zero = Zero
-type _ succ = Succ
-type _ nat = NZ : zero nat | NS : 'a nat -> 'a succ nat
-type _ fin = FZ : 'a succ fin | FS : 'a fin -> 'a succ fin
-type _ is_succ = IS : 'a succ is_succ
-val fin_succ : 'n fin -> 'n is_succ = 
-#                                     *   type 'a term = Var of 'a fin | Leaf | Fork of 'a term * 'a term
-val var : 'a fin -> 'a term = 
-val lift : ('m fin -> 'n fin) -> 'm fin -> 'n term = 
-val pre_subst : ('a fin -> 'b term) -> 'a term -> 'b term = 
-val comp_subst :
-  ('b fin -> 'c term) -> ('a fin -> 'b term) -> 'a fin -> 'c term = 
-#                                                                               val thin : 'n succ fin -> 'n fin -> 'n succ fin = 
-val bind : 'a option -> ('a -> 'b option) -> 'b option = 
-val thick : 'n succ fin -> 'n succ fin -> 'n fin option = 
-val check : 'n succ fin -> 'n succ term -> 'n term option = 
-val subst_var : 'a succ fin -> 'a term -> 'a succ fin -> 'a term = 
-val subst : 'a succ fin -> 'a term -> 'a succ term -> 'a term = 
-#                                                                                 type (_, _) alist =
-    Anil : ('n, 'n) alist
-  | Asnoc : ('m, 'n) alist * 'm term * 'm succ fin -> ('m succ, 'n) alist
-val sub : ('m, 'n) alist -> 'm fin -> 'n term = 
-val append : ('m, 'n) alist -> ('l, 'm) alist -> ('l, 'n) alist = 
-type _ ealist = EAlist : ('a, 'b) alist -> 'a ealist
-val asnoc : ('a, 'b) alist -> 'a term -> 'a succ fin -> 'a succ ealist =
-  
-val weaken_fin : 'n fin -> 'n succ fin = 
-val weaken_term : 'a term -> 'a succ term = 
-val weaken_alist : ('m, 'n) alist -> ('m succ, 'n succ) alist = 
-val sub' : 'm ealist -> 'm fin -> 'm term = 
-val subst' : 'a ealist -> 'a term -> 'a term = 
-#                                                           val flex_flex : 'a succ fin -> 'a succ fin -> 'a succ ealist = 
-val flex_rigid : 'a succ fin -> 'a succ term -> 'a succ ealist option = 
-val amgu : 'm term -> 'm term -> 'm ealist -> 'm ealist option = 
-val mgu : 'a term -> 'a term -> 'a ealist option = 
-#             val s : 'a succ succ succ term = Fork (Var FZ, Fork (Var (FS (FS FZ)), Leaf))
-val t : 'a succ succ term = Fork (Var (FS FZ), Var (FS FZ))
-val d : '_a succ succ succ ealist =
-  EAlist (Asnoc (Asnoc (Anil, Fork (Var FZ, Leaf), FZ), Var FZ, FZ))
-val s' : '_a succ succ succ term =
-  Fork (Fork (Var FZ, Leaf), Fork (Var FZ, Leaf))
-val t' : '_a succ succ succ term =
-  Fork (Fork (Var FZ, Leaf), Fork (Var FZ, Leaf))
-# 
diff --git a/testsuite/tests/typing-gadts/yallop_bugs.ml b/testsuite/tests/typing-gadts/yallop_bugs.ml
index 983822bc..b4e60e8c 100644
--- a/testsuite/tests/typing-gadts/yallop_bugs.ml
+++ b/testsuite/tests/typing-gadts/yallop_bugs.ml
@@ -12,6 +12,11 @@ let magic : 'a 'b. 'a -> 'b =
         (struct type 'a t = unit end)
     in M.f Refl
 ;;
+[%%expect{|
+type (_, _) eq = Refl : ('a, 'a) eq
+Line _, characters 44-52:
+Error: Type a is not a subtype of b
+|}];;
 
 (* Variance and subtyping *)
 
@@ -25,6 +30,11 @@ let magic : 'a 'b. 'a -> 'b =
       fun (type a) (Refl : (a, < >) eq) (s : < >) -> (s :> a) in
     (downcast bad_proof ((object method m = x end) :> < >)) # m
 ;;
+[%%expect{|
+Line _, characters 0-36:
+Error: In this GADT definition, the variance of some parameter
+       cannot be checked
+|}];;
 
 (* Record patterns *)
 
@@ -36,6 +46,14 @@ let check : type s . s t * s -> bool = function
   | BoolLit, false -> false
   | IntLit , 6 -> false
 ;;
+[%%expect{|
+type _ t = IntLit : int t | BoolLit : bool t
+Line _, characters 39-99:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(IntLit, 0)
+val check : 's t * 's -> bool = 
+|}];;
 
 type ('a, 'b) pair = { fst : 'a; snd : 'b }
 
@@ -43,3 +61,11 @@ let check : type s . (s t, s) pair -> bool = function
   | {fst = BoolLit; snd = false} -> false
   | {fst = IntLit ; snd =  6} -> false
 ;;
+[%%expect{|
+type ('a, 'b) pair = { fst : 'a; snd : 'b; }
+Line _, characters 45-134:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+{fst=IntLit; snd=0}
+val check : ('s t, 's) pair -> bool = 
+|}];;
diff --git a/testsuite/tests/typing-gadts/yallop_bugs.ml.principal.reference b/testsuite/tests/typing-gadts/yallop_bugs.ml.principal.reference
deleted file mode 100644
index accbebf4..00000000
--- a/testsuite/tests/typing-gadts/yallop_bugs.ml.principal.reference
+++ /dev/null
@@ -1,29 +0,0 @@
-
-#                           Characters 233-241:
-           let f (Refl : (a T.t, b T.t) eq) = (x :> b)
-                                              ^^^^^^^^
-Error: Type a is not a subtype of b 
-#                         Characters 31-67:
-  type (_, +_) eq = Refl : ('a, 'a) eq
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In this GADT definition, the variance of some parameter
-       cannot be checked
-#                     Characters 115-175:
-  .......................................function
-    | BoolLit, false -> false
-    | IntLit , 6 -> false
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(IntLit, 0)
-type _ t = IntLit : int t | BoolLit : bool t
-val check : 's t * 's -> bool = 
-#             Characters 91-180:
-  .............................................function
-    | {fst = BoolLit; snd = false} -> false
-    | {fst = IntLit ; snd =  6} -> false
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-{fst=IntLit; snd=0}
-type ('a, 'b) pair = { fst : 'a; snd : 'b; }
-val check : ('s t, 's) pair -> bool = 
-# 
diff --git a/testsuite/tests/typing-gadts/yallop_bugs.ml.reference b/testsuite/tests/typing-gadts/yallop_bugs.ml.reference
deleted file mode 100644
index accbebf4..00000000
--- a/testsuite/tests/typing-gadts/yallop_bugs.ml.reference
+++ /dev/null
@@ -1,29 +0,0 @@
-
-#                           Characters 233-241:
-           let f (Refl : (a T.t, b T.t) eq) = (x :> b)
-                                              ^^^^^^^^
-Error: Type a is not a subtype of b 
-#                         Characters 31-67:
-  type (_, +_) eq = Refl : ('a, 'a) eq
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In this GADT definition, the variance of some parameter
-       cannot be checked
-#                     Characters 115-175:
-  .......................................function
-    | BoolLit, false -> false
-    | IntLit , 6 -> false
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(IntLit, 0)
-type _ t = IntLit : int t | BoolLit : bool t
-val check : 's t * 's -> bool = 
-#             Characters 91-180:
-  .............................................function
-    | {fst = BoolLit; snd = false} -> false
-    | {fst = IntLit ; snd =  6} -> false
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-{fst=IntLit; snd=0}
-type ('a, 'b) pair = { fst : 'a; snd : 'b; }
-val check : ('s t, 's) pair -> bool = 
-# 
diff --git a/testsuite/tests/typing-immediate/Makefile b/testsuite/tests/typing-immediate/Makefile
index 7fc00661..0b15e777 100644
--- a/testsuite/tests/typing-immediate/Makefile
+++ b/testsuite/tests/typing-immediate/Makefile
@@ -14,5 +14,5 @@
 #**************************************************************************
 
 BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.expect
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-immediate/immediate.ml b/testsuite/tests/typing-immediate/immediate.ml
index 996469f9..559e2a11 100644
--- a/testsuite/tests/typing-immediate/immediate.ml
+++ b/testsuite/tests/typing-immediate/immediate.ml
@@ -1,5 +1,9 @@
 module type S = sig type t [@@immediate] end;;
 module F (M : S) : S = M;;
+[%%expect{|
+module type S = sig type t [@@immediate] end
+module F : functor (M : S) -> S
+|}];;
 
 (* VALID DECLARATIONS *)
 
@@ -17,40 +21,74 @@ module A = struct
   type p = q [@@immediate]
   and q = int
 end;;
+[%%expect{|
+module A :
+  sig
+    type t [@@immediate]
+    type s = t [@@immediate]
+    type r = s
+    type p = q [@@immediate]
+    and q = int
+  end
+|}];;
 
 (* Valid using with constraints *)
 module type X = sig type t end;;
 module Y = struct type t = int end;;
 module Z = ((Y : X with type t = int) : sig type t [@@immediate] end);;
+[%%expect{|
+module type X = sig type t end
+module Y : sig type t = int end
+module Z : sig type t [@@immediate] end
+|}];;
 
 (* Valid using an explicit signature *)
 module M_valid : S = struct type t = int end;;
 module FM_valid = F (struct type t = int end);;
+[%%expect{|
+module M_valid : S
+module FM_valid : S
+|}];;
 
 (* Practical usage over modules *)
 module Foo : sig type t val x : t ref end = struct
   type t = int
   let x = ref 0
 end;;
+[%%expect{|
+module Foo : sig type t val x : t ref end
+|}];;
 
 module Bar : sig type t [@@immediate] val x : t ref end = struct
   type t = int
   let x = ref 0
 end;;
+[%%expect{|
+module Bar : sig type t [@@immediate] val x : t ref end
+|}];;
 
 let test f =
   let start = Sys.time() in f ();
   (Sys.time() -. start);;
+[%%expect{|
+val test : (unit -> 'a) -> float = 
+|}];;
 
 let test_foo () =
   for i = 0 to 100_000_000 do
     Foo.x := !Foo.x
   done;;
+[%%expect{|
+val test_foo : unit -> unit = 
+|}];;
 
 let test_bar () =
   for i = 0 to 100_000_000 do
     Bar.x := !Bar.x
   done;;
+[%%expect{|
+val test_bar : unit -> unit = 
+|}];;
 
 (* Uncomment these to test. Should see substantial speedup!
 let () = Printf.printf "No @@immediate: %fs\n" (test test_foo)
@@ -63,24 +101,62 @@ let () = Printf.printf "With @@immediate: %fs\n" (test test_bar) *)
 module B = struct
   type t = string [@@immediate]
 end;;
+[%%expect{|
+Line _, characters 2-31:
+Error: Types marked with the immediate attribute must be
+       non-pointer types like int or bool
+|}];;
 
 (* Not guaranteed that t is immediate, so this is an invalid declaration *)
 module C = struct
   type t
   type s = t [@@immediate]
 end;;
+[%%expect{|
+Line _, characters 2-26:
+Error: Types marked with the immediate attribute must be
+       non-pointer types like int or bool
+|}];;
 
 (* Can't ascribe to an immediate type signature with a non-immediate type *)
 module D : sig type t [@@immediate] end = struct
   type t = string
 end;;
+[%%expect{|
+Line _, characters 42-70:
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = string end
+       is not included in
+         sig type t [@@immediate] end
+       Type declarations do not match:
+         type t = string
+       is not included in
+         type t [@@immediate]
+       the first is not an immediate type.
+|}];;
 
 (* Same as above but with explicit signature *)
 module M_invalid : S = struct type t = string end;;
 module FM_invalid = F (struct type t = string end);;
+[%%expect{|
+Line _, characters 23-49:
+Error: Signature mismatch:
+       Modules do not match: sig type t = string end is not included in S
+       Type declarations do not match:
+         type t = string
+       is not included in
+         type t [@@immediate]
+       the first is not an immediate type.
+|}];;
 
 (* Can't use a non-immediate type even if mutually recursive *)
 module E = struct
   type t = s [@@immediate]
   and s = string
 end;;
+[%%expect{|
+Line _, characters 2-26:
+Error: Types marked with the immediate attribute must be
+       non-pointer types like int or bool
+|}];;
diff --git a/testsuite/tests/typing-immediate/immediate.ml.reference b/testsuite/tests/typing-immediate/immediate.ml.reference
deleted file mode 100644
index d62a7061..00000000
--- a/testsuite/tests/typing-immediate/immediate.ml.reference
+++ /dev/null
@@ -1,71 +0,0 @@
-
-# module type S = sig type t [@@immediate] end
-# module F : functor (M : S) -> S
-#                                 module A :
-  sig
-    type t [@@immediate]
-    type s = t [@@immediate]
-    type r = s
-    type p = q [@@immediate]
-    and q = int
-  end
-#     module type X = sig type t end
-# module Y : sig type t = int end
-# module Z : sig type t [@@immediate] end
-#     module M_valid : S
-# module FM_valid : S
-#           module Foo : sig type t val x : t ref end
-#         module Bar : sig type t [@@immediate] val x : t ref end
-#       val test : (unit -> 'a) -> float = 
-#         val test_foo : unit -> unit = 
-#         val test_bar : unit -> unit = 
-#   * *                 Characters 306-335:
-    type t = string [@@immediate]
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Types marked with the immediate attribute must be
-       non-pointer types like int or bool
-#           Characters 106-130:
-    type s = t [@@immediate]
-    ^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Types marked with the immediate attribute must be
-       non-pointer types like int or bool
-#         Characters 120-148:
-  ..........................................struct
-    type t = string
-  end..
-Error: Signature mismatch:
-       Modules do not match:
-         sig type t = string end
-       is not included in
-         sig type t [@@immediate] end
-       Type declarations do not match:
-         type t = string
-       is not included in
-         type t [@@immediate]
-       the first is not an immediate type.
-#     Characters 72-98:
-  module M_invalid : S = struct type t = string end;;
-                         ^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Signature mismatch:
-       Modules do not match: sig type t = string end is not included in S
-       Type declarations do not match:
-         type t = string
-       is not included in
-         type t [@@immediate]
-       the first is not an immediate type.
-# Characters 23-49:
-  module FM_invalid = F (struct type t = string end);;
-                         ^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Signature mismatch:
-       Modules do not match: sig type t = string end is not included in S
-       Type declarations do not match:
-         type t = string
-       is not included in
-         type t [@@immediate]
-       the first is not an immediate type.
-#           Characters 85-109:
-    type t = s [@@immediate]
-    ^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Types marked with the immediate attribute must be
-       non-pointer types like int or bool
-# 
diff --git a/testsuite/tests/typing-misc/Makefile b/testsuite/tests/typing-misc/Makefile
index 7fc00661..0b15e777 100644
--- a/testsuite/tests/typing-misc/Makefile
+++ b/testsuite/tests/typing-misc/Makefile
@@ -14,5 +14,5 @@
 #**************************************************************************
 
 BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.expect
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-misc/constraints.ml b/testsuite/tests/typing-misc/constraints.ml
index a0063632..76a360df 100644
--- a/testsuite/tests/typing-misc/constraints.ml
+++ b/testsuite/tests/typing-misc/constraints.ml
@@ -1,19 +1,52 @@
 type 'a t = [`A of 'a t t] as 'a;; (* fails *)
-
+[%%expect{|
+Line _, characters 0-32:
+Error: The definition of t contains a cycle:
+       'a t t as 'a
+|}, Principal{|
+Line _, characters 0-32:
+Error: The definition of t contains a cycle:
+       [ `A of 'a t t ] as 'a
+|}];;
 type 'a t = [`A of 'a t t];; (* fails *)
-
-type 'a t = [`A of 'a t t] constraint 'a = 'a t;;
-
-type 'a t = [`A of 'a t] constraint 'a = 'a t;;
-
+[%%expect{|
+Line _, characters 0-26:
+Error: In the definition of t, type 'a t t should be 'a t
+|}];;
+type 'a t = [`A of 'a t t] constraint 'a = 'a t;; (* fails since 4.04 *)
+[%%expect{|
+Line _, characters 0-47:
+Error: The type abbreviation t is cyclic
+|}];;
+type 'a t = [`A of 'a t] constraint 'a = 'a t;; (* fails since 4.04 *)
+[%%expect{|
+Line _, characters 0-45:
+Error: The type abbreviation t is cyclic
+|}];;
 type 'a t = [`A of 'a] as 'a;;
-
+[%%expect{|
+type 'a t = 'a constraint 'a = [ `A of 'a ]
+|}, Principal{|
+type 'a t = [ `A of 'b ] as 'b constraint 'a = [ `A of 'a ]
+|}];;
 type 'a v = [`A of u v] constraint 'a = t and t = u and u = t;; (* fails *)
+[%%expect{|
+Line _, characters 0-41:
+Error: The definition of v contains a cycle:
+       t
+|}];;
 
 type 'a t = 'a;;
-let f (x : 'a t as 'a) = ();; (* fails *)
+let f (x : 'a t as 'a) = ();; (* ok *)
+[%%expect{|
+type 'a t = 'a
+val f : 'a -> unit = 
+|}];;
 
 let f (x : 'a t) (y : 'a) = x = y;;
+[%%expect{|
+val f : 'a t -> 'a -> bool = 
+|}];;
 
 (* PR#6505 *)
 module type PR6505 = sig
@@ -21,4 +54,59 @@ module type PR6505 = sig
   and 'o abs constraint 'o = 'o is_an_object
   val abs : 'o is_an_object -> 'o abs
   val unabs : 'o abs -> 'o
-end;; (* fails *)
+end
+;; (* fails *)
+[%%expect{|
+Line _, characters 2-44:
+Error: The definition of abs contains a cycle:
+       'a is_an_object as 'a
+|}];;
+
+module PR6505a = struct
+  type 'o is_an_object = < .. > as 'o
+  and ('k,'l) abs = 'l constraint 'k = 'l is_an_object
+  let y : ('o, 'o) abs = object end
+end;;
+let _ = PR6505a.y#bang;; (* fails *)
+[%%expect{|
+module PR6505a :
+  sig
+    type 'o is_an_object = 'o constraint 'o = < .. >
+    and ('a, 'l) abs = 'l constraint 'a = 'l is_an_object
+    val y : (<  > is_an_object, <  > is_an_object) abs
+  end
+Line _, characters 8-17:
+Error: This expression has type
+         (<  > PR6505a.is_an_object, <  > PR6505a.is_an_object) PR6505a.abs
+       It has no method bang
+|}, Principal{|
+module PR6505a :
+  sig
+    type 'o is_an_object = 'o constraint 'o = < .. >
+    and ('a, 'l) abs = 'l constraint 'a = 'l is_an_object
+    val y : (<  >, <  >) abs
+  end
+Line _, characters 8-17:
+Error: This expression has type (<  >, <  >) PR6505a.abs
+       It has no method bang
+|}]
+
+module PR6505b = struct
+  type 'o is_an_object = [> ] as 'o
+  and ('k,'l) abs = 'l constraint 'k = 'l is_an_object
+  let x : ('a, 'a) abs = `Foo 6
+end;;
+let () = print_endline (match PR6505b.x with `Bar s -> s);; (* fails *)
+[%%expect{|
+module PR6505b :
+  sig
+    type 'o is_an_object = 'o constraint 'o = [>  ]
+    and ('a, 'l) abs = 'l constraint 'a = 'l is_an_object
+    val x : (([> `Foo of int ] as 'a) is_an_object, 'a is_an_object) abs
+  end
+Line _, characters 23-57:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+`Foo _
+Exception: Match_failure ("", 6, 23).
+|}]
diff --git a/testsuite/tests/typing-misc/constraints.ml.reference b/testsuite/tests/typing-misc/constraints.ml.reference
deleted file mode 100644
index 41a324c6..00000000
--- a/testsuite/tests/typing-misc/constraints.ml.reference
+++ /dev/null
@@ -1,34 +0,0 @@
-
-# Characters 12-32:
-  type 'a t = [`A of 'a t t] as 'a;; (* fails *)
-              ^^^^^^^^^^^^^^^^^^^^
-Error: Constraints are not satisfied in this type.
-       Type
-       [ `A of 'a ] t t as 'a
-       should be an instance of
-       ([ `A of 'b t t ] as 'b) t
-#   Characters 1-27:
-  type 'a t = [`A of 'a t t];; (* fails *)
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In the definition of t, type 'a t t should be 'a t
-#   type 'a t = [ `A of 'a t t ] constraint 'a = 'a t
-#   type 'a t = [ `A of 'a t ] constraint 'a = 'a t
-#   type 'a t = 'a constraint 'a = [ `A of 'a ]
-#   Characters 43-52:
-  type 'a v = [`A of u v] constraint 'a = t and t = u and u = t;; (* fails *)
-                                            ^^^^^^^^^
-Error: The type abbreviation t is cyclic
-#   type 'a t = 'a
-# Characters 11-21:
-  let f (x : 'a t as 'a) = ();; (* fails *)
-             ^^^^^^^^^^
-Error: This alias is bound to type 'a t = 'a
-       but is used as an instance of type 'a
-       The type variable 'a occurs inside 'a
-#   val f : 'a t -> 'a -> bool = 
-#               Characters 80-122:
-    and 'o abs constraint 'o = 'o is_an_object
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: The definition of abs contains a cycle:
-       'a is_an_object as 'a
-# 
diff --git a/testsuite/tests/typing-misc/labels.ml b/testsuite/tests/typing-misc/labels.ml
index 2d4b9d19..bd6c3a6f 100644
--- a/testsuite/tests/typing-misc/labels.ml
+++ b/testsuite/tests/typing-misc/labels.ml
@@ -1,11 +1,27 @@
 (* PR#5835 *)
 let f ~x = x + 1;;
 f ?x:0;;
+[%%expect{|
+val f : x:int -> int = 
+Line _, characters 5-6:
+Warning 43: the label x is not optional.
+- : int = 1
+|}];;
 
 (* PR#6352 *)
 let foo (f : unit -> unit) = ();;
 let g ?x () = ();;
 foo ((); g);;
+[%%expect{|
+val foo : (unit -> unit) -> unit = 
+val g : ?x:'a -> unit -> unit = 
+- : unit = ()
+|}];;
 
 (* PR#5748 *)
 foo (fun ?opt () -> ()) ;; (* fails *)
+[%%expect{|
+Line _, characters 4-23:
+Error: This function should have type unit -> unit
+       but its first argument is labelled ?opt
+|}];;
diff --git a/testsuite/tests/typing-misc/labels.ml.principal.reference b/testsuite/tests/typing-misc/labels.ml.principal.reference
deleted file mode 100644
index f8be126b..00000000
--- a/testsuite/tests/typing-misc/labels.ml.principal.reference
+++ /dev/null
@@ -1,16 +0,0 @@
-
-#   val f : x:int -> int = 
-# Characters 5-6:
-  f ?x:0;;
-       ^
-Warning 43: the label x is not optional.
-- : int = 1
-#     val foo : (unit -> unit) -> unit = 
-# val g : ?x:'a -> unit -> unit = 
-# - : unit = ()
-#     Characters 19-38:
-  foo (fun ?opt () -> ()) ;; (* fails *)
-      ^^^^^^^^^^^^^^^^^^^
-Error: This function should have type unit -> unit
-       but its first argument is labelled ?opt
-# 
diff --git a/testsuite/tests/typing-misc/labels.ml.reference b/testsuite/tests/typing-misc/labels.ml.reference
deleted file mode 100644
index f8be126b..00000000
--- a/testsuite/tests/typing-misc/labels.ml.reference
+++ /dev/null
@@ -1,16 +0,0 @@
-
-#   val f : x:int -> int = 
-# Characters 5-6:
-  f ?x:0;;
-       ^
-Warning 43: the label x is not optional.
-- : int = 1
-#     val foo : (unit -> unit) -> unit = 
-# val g : ?x:'a -> unit -> unit = 
-# - : unit = ()
-#     Characters 19-38:
-  foo (fun ?opt () -> ()) ;; (* fails *)
-      ^^^^^^^^^^^^^^^^^^^
-Error: This function should have type unit -> unit
-       but its first argument is labelled ?opt
-# 
diff --git a/testsuite/tests/typing-misc/occur_check.ml b/testsuite/tests/typing-misc/occur_check.ml
index 5509b6f5..c2c95f56 100644
--- a/testsuite/tests/typing-misc/occur_check.ml
+++ b/testsuite/tests/typing-misc/occur_check.ml
@@ -2,4 +2,17 @@
 
 type 'a t = 'a;;
 let f (g : 'a list -> 'a t -> 'a) s = g s s;;
+[%%expect{|
+type 'a t = 'a
+Line _, characters 42-43:
+Error: This expression has type 'a list
+       but an expression was expected of type 'a t = 'a
+       The type variable 'a occurs inside 'a list
+|}];;
 let f (g : 'a * 'b -> 'a t -> 'a) s = g s s;;
+[%%expect{|
+Line _, characters 42-43:
+Error: This expression has type 'a * 'b
+       but an expression was expected of type 'a t = 'a
+       The type variable 'a occurs inside 'a * 'b
+|}];;
diff --git a/testsuite/tests/typing-misc/occur_check.ml.reference b/testsuite/tests/typing-misc/occur_check.ml.reference
deleted file mode 100644
index 865c7d64..00000000
--- a/testsuite/tests/typing-misc/occur_check.ml.reference
+++ /dev/null
@@ -1,15 +0,0 @@
-
-#     type 'a t = 'a
-# Characters 42-43:
-  let f (g : 'a list -> 'a t -> 'a) s = g s s;;
-                                            ^
-Error: This expression has type 'a list
-       but an expression was expected of type 'a t = 'a
-       The type variable 'a occurs inside 'a list
-# Characters 42-43:
-  let f (g : 'a * 'b -> 'a t -> 'a) s = g s s;;
-                                            ^
-Error: This expression has type 'a * 'b
-       but an expression was expected of type 'a t = 'a
-       The type variable 'a occurs inside 'a * 'b
-# 
diff --git a/testsuite/tests/typing-misc/polyvars.ml b/testsuite/tests/typing-misc/polyvars.ml
index de8cb221..a37eeb7b 100644
--- a/testsuite/tests/typing-misc/polyvars.ml
+++ b/testsuite/tests/typing-misc/polyvars.ml
@@ -1,10 +1,50 @@
 type ab = [ `A | `B ];;
 let f (x : [`A]) = match x with #ab -> 1;;
+[%%expect{|
+type ab = [ `A | `B ]
+Line _, characters 32-35:
+Error: This pattern matches values of type [? `A | `B ]
+       but a pattern was expected which matches values of type [ `A ]
+       The second variant type does not allow tag(s) `B
+|}];;
 let f x = ignore (match x with #ab -> 1); ignore (x : [`A]);;
+[%%expect{|
+Line _, characters 31-34:
+Error: This pattern matches values of type [? `B ]
+       but a pattern was expected which matches values of type [ `A ]
+       The second variant type does not allow tag(s) `B
+|}, Principal{|
+Line _, characters 31-34:
+Error: This pattern matches values of type [? `B ]
+       but a pattern was expected which matches values of type [ `A ]
+       Types for tag `B are incompatible
+|}];;
 let f x = ignore (match x with `A|`B -> 1); ignore (x : [`A]);;
+[%%expect{|
+Line _, characters 34-36:
+Error: This pattern matches values of type [? `B ]
+       but a pattern was expected which matches values of type [ `A ]
+       The second variant type does not allow tag(s) `B
+|}, Principal{|
+Line _, characters 34-36:
+Error: This pattern matches values of type [? `B ]
+       but a pattern was expected which matches values of type [ `A ]
+       Types for tag `B are incompatible
+|}];;
 
 let f (x : [< `A | `B]) = match x with `A | `B | `C -> 0;; (* warn *)
+[%%expect{|
+Line _, characters 49-51:
+Warning 12: this sub-pattern is unused.
+val f : [< `A | `B ] -> int = 
+|}];;
 let f (x : [`A | `B]) = match x with `A | `B | `C -> 0;; (* fail *)
+[%%expect{|
+Line _, characters 47-49:
+Error: This pattern matches values of type [? `C ]
+       but a pattern was expected which matches values of type [ `A | `B ]
+       The second variant type does not allow tag(s) `C
+|}];;
 
 (* PR#6787 *)
 let revapply x f = f x;;
@@ -13,3 +53,7 @@ let f x (g : [< `Foo]) =
   let y = `Bar x, g in
   revapply y (fun ((`Bar i), _) -> i);;
 (* f : 'a -> [< `Foo ] -> 'a *)
+[%%expect{|
+val revapply : 'a -> ('a -> 'b) -> 'b = 
+val f : 'a -> [< `Foo ] -> 'a = 
+|}];;
diff --git a/testsuite/tests/typing-misc/polyvars.ml.principal.reference b/testsuite/tests/typing-misc/polyvars.ml.principal.reference
deleted file mode 100644
index 6732640e..00000000
--- a/testsuite/tests/typing-misc/polyvars.ml.principal.reference
+++ /dev/null
@@ -1,34 +0,0 @@
-
-# type ab = [ `A | `B ]
-# Characters 32-35:
-  let f (x : [`A]) = match x with #ab -> 1;;
-                                  ^^^
-Error: This pattern matches values of type [? `A | `B ]
-       but a pattern was expected which matches values of type [ `A ]
-       The second variant type does not allow tag(s) `B
-# Characters 31-34:
-  let f x = ignore (match x with #ab -> 1); ignore (x : [`A]);;
-                                 ^^^
-Error: This pattern matches values of type [? `B ]
-       but a pattern was expected which matches values of type [ `A ]
-       Types for tag `B are incompatible
-# Characters 34-36:
-  let f x = ignore (match x with `A|`B -> 1); ignore (x : [`A]);;
-                                    ^^
-Error: This pattern matches values of type [? `B ]
-       but a pattern was expected which matches values of type [ `A ]
-       Types for tag `B are incompatible
-#   Characters 50-52:
-  let f (x : [< `A | `B]) = match x with `A | `B | `C -> 0;; (* warn *)
-                                                   ^^
-Warning 12: this sub-pattern is unused.
-val f : [< `A | `B ] -> int = 
-# Characters 47-49:
-  let f (x : [`A | `B]) = match x with `A | `B | `C -> 0;; (* fail *)
-                                                 ^^
-Error: This pattern matches values of type [? `C ]
-       but a pattern was expected which matches values of type [ `A | `B ]
-       The second variant type does not allow tag(s) `C
-#     val revapply : 'a -> ('a -> 'b) -> 'b = 
-#       val f : 'a -> [< `Foo ] -> 'a = 
-#   
diff --git a/testsuite/tests/typing-misc/polyvars.ml.reference b/testsuite/tests/typing-misc/polyvars.ml.reference
deleted file mode 100644
index 751b02fc..00000000
--- a/testsuite/tests/typing-misc/polyvars.ml.reference
+++ /dev/null
@@ -1,34 +0,0 @@
-
-# type ab = [ `A | `B ]
-# Characters 32-35:
-  let f (x : [`A]) = match x with #ab -> 1;;
-                                  ^^^
-Error: This pattern matches values of type [? `A | `B ]
-       but a pattern was expected which matches values of type [ `A ]
-       The second variant type does not allow tag(s) `B
-# Characters 31-34:
-  let f x = ignore (match x with #ab -> 1); ignore (x : [`A]);;
-                                 ^^^
-Error: This pattern matches values of type [? `B ]
-       but a pattern was expected which matches values of type [ `A ]
-       The second variant type does not allow tag(s) `B
-# Characters 34-36:
-  let f x = ignore (match x with `A|`B -> 1); ignore (x : [`A]);;
-                                    ^^
-Error: This pattern matches values of type [? `B ]
-       but a pattern was expected which matches values of type [ `A ]
-       The second variant type does not allow tag(s) `B
-#   Characters 50-52:
-  let f (x : [< `A | `B]) = match x with `A | `B | `C -> 0;; (* warn *)
-                                                   ^^
-Warning 12: this sub-pattern is unused.
-val f : [< `A | `B ] -> int = 
-# Characters 47-49:
-  let f (x : [`A | `B]) = match x with `A | `B | `C -> 0;; (* fail *)
-                                                 ^^
-Error: This pattern matches values of type [? `C ]
-       but a pattern was expected which matches values of type [ `A | `B ]
-       The second variant type does not allow tag(s) `C
-#     val revapply : 'a -> ('a -> 'b) -> 'b = 
-#       val f : 'a -> [< `Foo ] -> 'a = 
-#   
diff --git a/testsuite/tests/typing-misc/pr6939.ml b/testsuite/tests/typing-misc/pr6939.ml
index 0ed82035..2acdd12e 100755
--- a/testsuite/tests/typing-misc/pr6939.ml
+++ b/testsuite/tests/typing-misc/pr6939.ml
@@ -1,4 +1,15 @@
-
 let rec x = [| x |]; 1.;;
+[%%expect{|
+Line _, characters 12-19:
+Warning 10: this expression should have type unit.
+Line _, characters 12-23:
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+|}];;
 
 let rec x = let u = [|y|] in 10. and y = 1.;;
+[%%expect{|
+Line _, characters 16-17:
+Warning 26: unused variable u.
+Line _, characters 12-32:
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+|}];;
diff --git a/testsuite/tests/typing-misc/pr6939.ml.reference b/testsuite/tests/typing-misc/pr6939.ml.reference
deleted file mode 100644
index 3a452cce..00000000
--- a/testsuite/tests/typing-misc/pr6939.ml.reference
+++ /dev/null
@@ -1,18 +0,0 @@
-
-#   Characters 13-20:
-  let rec x = [| x |]; 1.;;
-              ^^^^^^^
-Warning 10: this expression should have type unit.
-Characters 13-24:
-  let rec x = [| x |]; 1.;;
-              ^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-#   Characters 17-18:
-  let rec x = let u = [|y|] in 10. and y = 1.;;
-                  ^
-Warning 26: unused variable u.
-Characters 13-33:
-  let rec x = let u = [|y|] in 10. and y = 1.;;
-              ^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# 
diff --git a/testsuite/tests/typing-misc/pr7103.ml b/testsuite/tests/typing-misc/pr7103.ml
index bdca4b34..f7420fd2 100644
--- a/testsuite/tests/typing-misc/pr7103.ml
+++ b/testsuite/tests/typing-misc/pr7103.ml
@@ -6,9 +6,34 @@ let f : < .. > t -> unit = fun _ -> ();;
 let g : [< `b] t -> unit = fun _ -> ();;
 
 let h : [> `b] t -> unit = fun _ -> ();;
+[%%expect{|
+type 'a t
+type a
+val f : < .. > t -> unit = 
+val g : [< `b ] t -> unit = 
+val h : [> `b ] t -> unit = 
+|}];;
 
 let _ = fun (x : a t) -> f x;;
+[%%expect{|
+Line _, characters 27-28:
+Error: This expression has type a t but an expression was expected of type
+         (< .. > as 'a) t
+       Type a is not compatible with type < .. > as 'a
+|}];;
 
 let _ = fun (x : a t) -> g x;;
+[%%expect{|
+Line _, characters 27-28:
+Error: This expression has type a t but an expression was expected of type
+         ([< `b ] as 'a) t
+       Type a is not compatible with type [< `b ] as 'a
+|}];;
 
 let _ = fun (x : a t) -> h x;;
+[%%expect{|
+Line _, characters 27-28:
+Error: This expression has type a t but an expression was expected of type
+         ([> `b ] as 'a) t
+       Type a is not compatible with type [> `b ] as 'a
+|}];;
diff --git a/testsuite/tests/typing-misc/pr7103.ml.reference b/testsuite/tests/typing-misc/pr7103.ml.reference
deleted file mode 100644
index e7457063..00000000
--- a/testsuite/tests/typing-misc/pr7103.ml.reference
+++ /dev/null
@@ -1,25 +0,0 @@
-
-#       type 'a t
-type a
-val f : < .. > t -> unit = 
-#   val g : [< `b ] t -> unit = 
-#   val h : [> `b ] t -> unit = 
-#   Characters 28-29:
-  let _ = fun (x : a t) -> f x;;
-                             ^
-Error: This expression has type a t but an expression was expected of type
-         (< .. > as 'a) t
-       Type a is not compatible with type < .. > as 'a 
-#   Characters 28-29:
-  let _ = fun (x : a t) -> g x;;
-                             ^
-Error: This expression has type a t but an expression was expected of type
-         ([< `b ] as 'a) t
-       Type a is not compatible with type [< `b ] as 'a 
-#   Characters 28-29:
-  let _ = fun (x : a t) -> h x;;
-                             ^
-Error: This expression has type a t but an expression was expected of type
-         ([> `b ] as 'a) t
-       Type a is not compatible with type [> `b ] as 'a 
-# 
diff --git a/testsuite/tests/typing-misc/pr7228.ml b/testsuite/tests/typing-misc/pr7228.ml
new file mode 100755
index 00000000..a9f0cb1a
--- /dev/null
+++ b/testsuite/tests/typing-misc/pr7228.ml
@@ -0,0 +1,15 @@
+type t = A of {mutable x: int};;
+fun (A r) -> r.x <- 42;;
+[%%expect{|
+type t = A of { mutable x : int; }
+- : t -> unit = 
+|}];;
+
+(* Check that mutability is blocked for inline records on private types *)
+type t = private A of {mutable x: int};;
+fun (A r) -> r.x <- 42;;
+[%%expect{|
+type t = private A of { mutable x : int; }
+Line _, characters 15-16:
+Error: Cannot assign field x of the private type t.A
+|}];;
diff --git a/testsuite/tests/typing-misc/printing.ml b/testsuite/tests/typing-misc/printing.ml
index 8a9c2310..277c3864 100644
--- a/testsuite/tests/typing-misc/printing.ml
+++ b/testsuite/tests/typing-misc/printing.ml
@@ -1,7 +1,18 @@
 (* PR#7012 *)
 
 type t = [ 'A_name | `Hi ];;
+[%%expect{|
+Line _, characters 11-18:
+Error: The type 'A_name is not a polymorphic variant type
+Hint: Did you mean `A_name?
+|}];;
 
 let f (x:'id_arg) = x;;
+[%%expect{|
+val f : 'id_arg -> 'id_arg = 
+|}];;
 
 let f (x:'Id_arg) = x;;
+[%%expect{|
+val f : 'Id_arg -> 'Id_arg = 
+|}];;
diff --git a/testsuite/tests/typing-misc/printing.ml.reference b/testsuite/tests/typing-misc/printing.ml.reference
deleted file mode 100644
index 21763b2d..00000000
--- a/testsuite/tests/typing-misc/printing.ml.reference
+++ /dev/null
@@ -1,9 +0,0 @@
-
-#     Characters 26-33:
-  type t = [ 'A_name | `Hi ];;
-             ^^^^^^^
-Error: The type 'A_name is not a polymorphic variant type
-Hint: Did you mean `A_name?
-#   val f : 'id_arg -> 'id_arg = 
-#   val f : 'Id_arg -> 'Id_arg = 
-# 
diff --git a/testsuite/tests/typing-misc/records.ml b/testsuite/tests/typing-misc/records.ml
index ae296cf1..f6d9100c 100644
--- a/testsuite/tests/typing-misc/records.ml
+++ b/testsuite/tests/typing-misc/records.ml
@@ -1,38 +1,112 @@
 (* undefined labels *)
 type t = {x:int;y:int};;
 {x=3;z=2};;
+[%%expect{|
+type t = { x : int; y : int; }
+Line _, characters 5-6:
+Error: Unbound record field z
+|}];;
 fun {x=3;z=2} -> ();;
+[%%expect{|
+Line _, characters 9-10:
+Error: Unbound record field z
+|}];;
 
 (* mixed labels *)
 {x=3; contents=2};;
+[%%expect{|
+Line _, characters 6-14:
+Error: The record field contents belongs to the type 'a ref
+       but is mixed here with fields of type t
+|}];;
 
 (* private types *)
 type u = private {mutable u:int};;
 {u=3};;
+[%%expect{|
+type u = private { mutable u : int; }
+Line _, characters 0-5:
+Error: Cannot create values of the private type u
+|}];;
 fun x -> x.u <- 3;;
+[%%expect{|
+Line _, characters 11-12:
+Error: Cannot assign field u of the private type u
+|}];;
 
 (* Punning and abbreviations *)
 module M = struct
   type t = {x: int; y: int}
 end;;
+[%%expect{|
+module M : sig type t = { x : int; y : int; } end
+|}];;
 
 let f {M.x; y} = x+y;;
 let r = {M.x=1; y=2};;
 let z = f r;;
+[%%expect{|
+val f : M.t -> int = 
+val r : M.t = {M.x = 1; y = 2}
+val z : int = 3
+|}];;
 
 (* messages *)
 type foo = { mutable y:int };;
 let f (r: int) = r.y <- 3;;
+[%%expect{|
+type foo = { mutable y : int; }
+Line _, characters 17-18:
+Error: This expression has type int but an expression was expected of type
+         foo
+|}];;
 
 (* bugs *)
 type foo = { y: int; z: int };;
 type bar = { x: int };;
 let f (r: bar) = ({ r with z = 3 } : foo)
+[%%expect{|
+type foo = { y : int; z : int; }
+type bar = { x : int; }
+Line _, characters 20-21:
+Error: This expression has type bar but an expression was expected of type
+         foo
+|}];;
 
 type foo = { x: int };;
 let r : foo = { ZZZ.x = 2 };;
+[%%expect{|
+type foo = { x : int; }
+Line _, characters 16-21:
+Error: Unbound module ZZZ
+|}];;
 
 (ZZZ.X : int option);;
+[%%expect{|
+Line _, characters 1-6:
+Error: Unbound module ZZZ
+|}];;
 
 (* PR#5865 *)
 let f (x : Complex.t) = x.Complex.z;;
+[%%expect{|
+Line _, characters 26-35:
+Error: Unbound record field Complex.z
+|}];;
+
+
+(* PR#6608 *)
+{ "reference" with contents = 0 }
+[%%expect{|
+Line _, characters 0-33:
+Warning 23: all the fields are explicitly listed in this record:
+the 'with' clause is useless.
+- : int ref = {contents = 0}
+|}];;
+{ true with contents = 0 }
+[%%expect{|
+Line _, characters 0-26:
+Warning 23: all the fields are explicitly listed in this record:
+the 'with' clause is useless.
+- : int ref = {contents = 0}
+|}];;
diff --git a/testsuite/tests/typing-misc/records.ml.principal.reference b/testsuite/tests/typing-misc/records.ml.principal.reference
deleted file mode 100644
index f084d039..00000000
--- a/testsuite/tests/typing-misc/records.ml.principal.reference
+++ /dev/null
@@ -1,54 +0,0 @@
-
-#   type t = { x : int; y : int; }
-# Characters 5-6:
-  {x=3;z=2};;
-       ^
-Error: Unbound record field z
-# Characters 9-10:
-  fun {x=3;z=2} -> ();;
-           ^
-Error: Unbound record field z
-#     Characters 26-34:
-  {x=3; contents=2};;
-        ^^^^^^^^
-Error: The record field contents belongs to the type 'a ref
-       but is mixed here with fields of type t
-#     type u = private { mutable u : int; }
-# Characters 0-5:
-  {u=3};;
-  ^^^^^
-Error: Cannot create values of the private type u
-# Characters 11-12:
-  fun x -> x.u <- 3;;
-             ^
-Error: Cannot assign field u of the private type u
-#         module M : sig type t = { x : int; y : int; } end
-#   val f : M.t -> int = 
-# val r : M.t = {M.x = 1; y = 2}
-# val z : int = 3
-#     type foo = { mutable y : int; }
-# Characters 17-18:
-  let f (r: int) = r.y <- 3;;
-                   ^
-Error: This expression has type int but an expression was expected of type
-         foo
-#     type foo = { y : int; z : int; }
-# type bar = { x : int; }
-#     Characters 20-21:
-  let f (r: bar) = ({ r with z = 3 } : foo)
-                      ^
-Error: This expression has type bar but an expression was expected of type
-         foo
-# Characters 16-21:
-  let r : foo = { ZZZ.x = 2 };;
-                  ^^^^^
-Error: Unbound module ZZZ
-#   Characters 2-7:
-  (ZZZ.X : int option);;
-   ^^^^^
-Error: Unbound module ZZZ
-#     Characters 41-50:
-  let f (x : Complex.t) = x.Complex.z;;
-                            ^^^^^^^^^
-Error: Unbound record field Complex.z
-# 
diff --git a/testsuite/tests/typing-misc/records.ml.reference b/testsuite/tests/typing-misc/records.ml.reference
deleted file mode 100644
index f084d039..00000000
--- a/testsuite/tests/typing-misc/records.ml.reference
+++ /dev/null
@@ -1,54 +0,0 @@
-
-#   type t = { x : int; y : int; }
-# Characters 5-6:
-  {x=3;z=2};;
-       ^
-Error: Unbound record field z
-# Characters 9-10:
-  fun {x=3;z=2} -> ();;
-           ^
-Error: Unbound record field z
-#     Characters 26-34:
-  {x=3; contents=2};;
-        ^^^^^^^^
-Error: The record field contents belongs to the type 'a ref
-       but is mixed here with fields of type t
-#     type u = private { mutable u : int; }
-# Characters 0-5:
-  {u=3};;
-  ^^^^^
-Error: Cannot create values of the private type u
-# Characters 11-12:
-  fun x -> x.u <- 3;;
-             ^
-Error: Cannot assign field u of the private type u
-#         module M : sig type t = { x : int; y : int; } end
-#   val f : M.t -> int = 
-# val r : M.t = {M.x = 1; y = 2}
-# val z : int = 3
-#     type foo = { mutable y : int; }
-# Characters 17-18:
-  let f (r: int) = r.y <- 3;;
-                   ^
-Error: This expression has type int but an expression was expected of type
-         foo
-#     type foo = { y : int; z : int; }
-# type bar = { x : int; }
-#     Characters 20-21:
-  let f (r: bar) = ({ r with z = 3 } : foo)
-                      ^
-Error: This expression has type bar but an expression was expected of type
-         foo
-# Characters 16-21:
-  let r : foo = { ZZZ.x = 2 };;
-                  ^^^^^
-Error: Unbound module ZZZ
-#   Characters 2-7:
-  (ZZZ.X : int option);;
-   ^^^^^
-Error: Unbound module ZZZ
-#     Characters 41-50:
-  let f (x : Complex.t) = x.Complex.z;;
-                            ^^^^^^^^^
-Error: Unbound record field Complex.z
-# 
diff --git a/testsuite/tests/typing-misc/variant.ml b/testsuite/tests/typing-misc/variant.ml
index b0bd5222..de83454a 100644
--- a/testsuite/tests/typing-misc/variant.ml
+++ b/testsuite/tests/typing-misc/variant.ml
@@ -6,3 +6,15 @@ end = struct
  type t = A | B
  let f = function A | B -> 0
 end;;
+[%%expect{|
+Line _, characters 6-61:
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = X.t = A | B val f : t -> int end
+       is not included in
+         sig type t = int * bool end
+       Type declarations do not match:
+         type t = X.t = A | B
+       is not included in
+         type t = int * bool
+|}];;
diff --git a/testsuite/tests/typing-misc/variant.ml.reference b/testsuite/tests/typing-misc/variant.ml.reference
deleted file mode 100644
index 4de6b611..00000000
--- a/testsuite/tests/typing-misc/variant.ml.reference
+++ /dev/null
@@ -1,16 +0,0 @@
-
-#               Characters 61-116:
-  ......struct
-   type t = A | B
-   let f = function A | B -> 0
-  end..
-Error: Signature mismatch:
-       Modules do not match:
-         sig type t = X.t = A | B val f : t -> int end
-       is not included in
-         sig type t = int * bool end
-       Type declarations do not match:
-         type t = X.t = A | B
-       is not included in
-         type t = int * bool
-# 
diff --git a/testsuite/tests/typing-misc/wellfounded.ml b/testsuite/tests/typing-misc/wellfounded.ml
index b33adc5e..99dc4c97 100644
--- a/testsuite/tests/typing-misc/wellfounded.ml
+++ b/testsuite/tests/typing-misc/wellfounded.ml
@@ -9,3 +9,8 @@ let f : type t. t prod -> _ = function Prod ->
     end
   in ()
 ;;
+[%%expect{|
+type _ prod = Prod : ('a * 'y) prod
+Line _, characters 6-20:
+Error: The type abbreviation d is cyclic
+|}];;
diff --git a/testsuite/tests/typing-misc/wellfounded.ml.principal.reference b/testsuite/tests/typing-misc/wellfounded.ml.principal.reference
deleted file mode 100644
index 04bf5586..00000000
--- a/testsuite/tests/typing-misc/wellfounded.ml.principal.reference
+++ /dev/null
@@ -1,7 +0,0 @@
-
-#     type _ prod = Prod : ('a * 'y) prod
-#               Characters 82-96:
-        type d = d * d
-        ^^^^^^^^^^^^^^
-Error: The type abbreviation d is cyclic
-# 
diff --git a/testsuite/tests/typing-misc/wellfounded.ml.reference b/testsuite/tests/typing-misc/wellfounded.ml.reference
deleted file mode 100644
index 04bf5586..00000000
--- a/testsuite/tests/typing-misc/wellfounded.ml.reference
+++ /dev/null
@@ -1,7 +0,0 @@
-
-#     type _ prod = Prod : ('a * 'y) prod
-#               Characters 82-96:
-        type d = d * d
-        ^^^^^^^^^^^^^^
-Error: The type abbreviation d is cyclic
-# 
diff --git a/testsuite/tests/typing-missing-cmi/Makefile b/testsuite/tests/typing-missing-cmi/Makefile
index 6a18f649..bc0ce930 100644
--- a/testsuite/tests/typing-missing-cmi/Makefile
+++ b/testsuite/tests/typing-missing-cmi/Makefile
@@ -1,13 +1,21 @@
+# Tests for compilation with missing cmis
+# main.ml: error message when equality is missing
+# main_ok.ml: allow path expansion even when the target is missing (GPR#816)
+
+SOURCES = subdir/m.ml a.ml b.ml c.ml main.ml main_ok.ml
 
 .PHONY: default
-default: subdir/m.ml a.ml b.ml main.ml
+default: $(SOURCES)
 	@printf " ... testing 'main.ml'";
 	@$(OCAMLC) -c subdir/m.ml;
 	@$(OCAMLC) -c -I subdir a.ml;
 	@$(OCAMLC) -c -I subdir b.ml;
+	@$(OCAMLC) -c -I subdir c.ml;
 	@$(OCAMLC) -c main.ml > main.ml.result 2>&1 || :
 	@$(DIFF) main.ml.result main.ml.reference >/dev/null \
 	&& echo " => passed" || echo " => failed"
+	@printf " ... testing 'main_ok.ml'";
+	@$(OCAMLC) -c main_ok.ml && echo " => passed" || echo " => failed"
 
 .PHONY: clean
 clean:
diff --git a/testsuite/tests/typing-missing-cmi/c.ml b/testsuite/tests/typing-missing-cmi/c.ml
new file mode 100644
index 00000000..35a6ce59
--- /dev/null
+++ b/testsuite/tests/typing-missing-cmi/c.ml
@@ -0,0 +1,10 @@
+(* GPR#816 *)
+(* This PR means that Foo(Bar).t is known to be equal to Foo(Baz).t
+   when Bar is an alias for Baz, even when the definition for Foo is unknown.
+   This can happen when .cmi files depend on other .cmi files not in the path
+   -- a situation that is partially supported. *)
+
+module A = M
+
+type t1 = M.Foo(M).t
+type t2 = A.Foo(A).t
diff --git a/testsuite/tests/typing-missing-cmi/main_ok.ml b/testsuite/tests/typing-missing-cmi/main_ok.ml
new file mode 100644
index 00000000..e6907190
--- /dev/null
+++ b/testsuite/tests/typing-missing-cmi/main_ok.ml
@@ -0,0 +1 @@
+let f (x : C.t1) = (x : C.t2)
diff --git a/testsuite/tests/typing-missing-cmi/subdir/m.ml b/testsuite/tests/typing-missing-cmi/subdir/m.ml
index 32870c88..c939a6a6 100644
--- a/testsuite/tests/typing-missing-cmi/subdir/m.ml
+++ b/testsuite/tests/typing-missing-cmi/subdir/m.ml
@@ -1,2 +1,4 @@
 type a = int
 type b = a
+
+module Foo(X : sig end) = struct type t = T end
diff --git a/testsuite/tests/typing-modules-bugs/pr6752_bad.ml b/testsuite/tests/typing-modules-bugs/pr6752_bad.ml
new file mode 100644
index 00000000..6f0f5f47
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr6752_bad.ml
@@ -0,0 +1,46 @@
+(* Sorry, we have to disable this as this requires accepting
+   potentially badly formed programs (after expliciting) *)
+
+module Common0 =
+ struct
+   type msg = Msg
+
+   let handle_msg = ref (function _ -> failwith "Unable to handle message")
+   let extend_handle f =
+   let old = !handle_msg in
+   handle_msg := f old
+
+   let q : _ Queue.t = Queue.create ()
+   let add msg = Queue.add msg q
+   let handle_queue_messages () = Queue.iter !handle_msg q
+ end
+
+let q' : Common0.msg Queue.t = Common0.q
+
+module Common =
+ struct
+   type msg = ..
+
+   let handle_msg = ref (function _ -> failwith "Unable to handle message")
+   let extend_handle f =
+   let old = !handle_msg in
+   handle_msg := f old
+
+   let q : _ Queue.t = Queue.create ()
+   let add msg = Queue.add msg q
+   let handle_queue_messages () = Queue.iter !handle_msg q
+ end
+
+module M1 =
+ struct
+   type Common.msg += Reload of string | Alert of string
+
+   let handle fallback = function
+     Reload s -> print_endline ("Reload "^s)
+   | Alert s -> print_endline ("Alert "^s)
+   | x -> fallback x
+
+   let () = Common.extend_handle handle
+   let () = Common.add (Reload "config.file")
+   let () = Common.add (Alert "Initialisation done")
+ end
diff --git a/testsuite/tests/typing-modules-bugs/pr6752_ok.ml b/testsuite/tests/typing-modules-bugs/pr6752_ok.ml
index 846af0d1..cc342ec6 100644
--- a/testsuite/tests/typing-modules-bugs/pr6752_ok.ml
+++ b/testsuite/tests/typing-modules-bugs/pr6752_ok.ml
@@ -1,3 +1,5 @@
+(* Adding a type annotation is sufficient to make typing go through *)
+
 module Common0 =
  struct
    type msg = Msg
@@ -7,7 +9,7 @@ module Common0 =
    let old = !handle_msg in
    handle_msg := f old
 
-   let q : _ Queue.t = Queue.create ()
+   let q : msg Queue.t = Queue.create ()
    let add msg = Queue.add msg q
    let handle_queue_messages () = Queue.iter !handle_msg q
  end
@@ -23,7 +25,7 @@ module Common =
    let old = !handle_msg in
    handle_msg := f old
 
-   let q : _ Queue.t = Queue.create ()
+   let q : msg Queue.t = Queue.create ()
    let add msg = Queue.add msg q
    let handle_queue_messages () = Queue.iter !handle_msg q
  end
diff --git a/testsuite/tests/typing-modules-bugs/pr7112_bad.ml b/testsuite/tests/typing-modules-bugs/pr7112_bad.ml
new file mode 100644
index 00000000..9f4a12d2
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr7112_bad.ml
@@ -0,0 +1,5 @@
+module A = struct module type S module S = struct end end
+module F (_ : sig end) = struct module type S module S = A.S end
+module M = struct end
+module N = M
+module G (X : F(N).S) : A.S = X
diff --git a/testsuite/tests/typing-modules-bugs/pr7112_ok.ml b/testsuite/tests/typing-modules-bugs/pr7112_ok.ml
new file mode 100644
index 00000000..9da56069
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr7112_ok.ml
@@ -0,0 +1,4 @@
+module F (_ : sig end) = struct module type S end
+module M = struct end
+module N = M
+module G (X : F(N).S) : F(M).S = X
diff --git a/testsuite/tests/typing-modules-bugs/pr7152_ok.ml b/testsuite/tests/typing-modules-bugs/pr7152_ok.ml
index 59491f35..662d8c26 100644
--- a/testsuite/tests/typing-modules-bugs/pr7152_ok.ml
+++ b/testsuite/tests/typing-modules-bugs/pr7152_ok.ml
@@ -33,6 +33,49 @@ end = struct
     let key = Fast.create ()
   end
 
+  let _ = Dem.key (* force to evaluation the lazy substitution *)
+
+  module EDem = Fast.Register(Dem)
+
+  let add_dec dec =
+    Fast.attach Dem.key dec
+end
+
+(* variant without using a Data module *)
+
+module M' :  sig
+  type make_dec
+  val add_dec: make_dec -> unit
+end = struct
+  type u
+
+  module Fast: sig
+    type 'd t
+    val create: unit -> 'd t
+    module type S = sig
+      type data
+      val key: data t
+    end
+    module Register (D:S): sig end
+    val attach: 'd t -> 'd -> unit
+  end = struct
+    type 'd t = unit
+    let create () = ()
+    module type S = sig
+      type data
+      val key: data t
+    end
+    module Register (D:S) = struct end
+    let attach _ _ = ()
+  end
+
+  type make_dec
+
+  module Dem = struct
+    type data = make_dec
+    let key = Fast.create ()
+  end
+
   module EDem = Fast.Register(Dem)
 
   let add_dec dec =
diff --git a/testsuite/tests/typing-modules-bugs/pr7305_principal.ml b/testsuite/tests/typing-modules-bugs/pr7305_principal.ml
new file mode 100644
index 00000000..fd20e998
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr7305_principal.ml
@@ -0,0 +1,29 @@
+type c1 = < c1: c1 >
+type c2 = < c1: c1; c2: c1; c3: c1; c4: c1; c5: c1; c6: c1 >
+type c3 = < c1: c2; c2: c2; c3: c2; c4: c2; c5: c2; c6: c2 >
+type c4 = < c1: c3; c2: c3; c3: c3; c4: c3; c5: c3; c6: c3 >
+type c5 = < c1: c4; c2: c4; c3: c4; c4: c4; c5: c4; c6: c4 >
+type c6 = < c1: c5; c2: c5; c3: c5; c4: c5; c5: c5; c6: c5 >
+type c7 = < c1: c6; c2: c6; c3: c6; c4: c6; c5: c6; c6: c6 >
+
+(* If you use this example, then checking the types themselves
+   takes a long time.
+type c1 = < c1: c1; c2: c2; c3: c3; c4: c4; c5: c5; c6: c6 >
+and  c2 = < c1: c1; c2: c2; c3: c3; c4: c4; c5: c5; c6: c6 >
+and  c3 = < c1: c1; c2: c2; c3: c3; c4: c4; c5: c5; c6: c6 >
+and  c4 = < c1: c1; c2: c2; c3: c3; c4: c4; c5: c5; c6: c6 >
+and  c5 = < c1: c1; c2: c2; c3: c3; c4: c4; c5: c5; c6: c6 >
+and  c6 = < c1: c1; c2: c2; c3: c3; c4: c4; c5: c5; c6: c6 >
+*)
+
+(* Same for this example
+type 'a c1 = 
+type 'a c2 = 
+type 'a c3 = 
+type 'a c4 = 
+type 'a c5 = 
+type 'a c6 = 
+type 'a c7 = 
+*)
+
+let x = ref ([] : c7 list)
diff --git a/testsuite/tests/typing-modules/Makefile b/testsuite/tests/typing-modules/Makefile
index 7fc00661..0b15e777 100644
--- a/testsuite/tests/typing-modules/Makefile
+++ b/testsuite/tests/typing-modules/Makefile
@@ -14,5 +14,5 @@
 #**************************************************************************
 
 BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.expect
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-modules/Test.ml b/testsuite/tests/typing-modules/Test.ml
index 640655eb..149ba154 100644
--- a/testsuite/tests/typing-modules/Test.ml
+++ b/testsuite/tests/typing-modules/Test.ml
@@ -2,9 +2,17 @@
 
 module type S = sig type t and s = t end;;
 module type S' = S with type t := int;;
+[%%expect{|
+module type S = sig type t and s = t end
+module type S' = sig type s = int end
+|}];;
 
 module type S = sig module rec M : sig end and N : sig end end;;
 module type S' = S with module M := String;;
+[%%expect{|
+module type S = sig module rec M : sig  end and N : sig  end end
+module type S' = sig module rec N : sig  end end
+|}];;
 
 (* with module type *)
 (*
@@ -30,33 +38,74 @@ type -'a t
 class type c = object method m : [ `A ] t end;;
 module M : sig val v : (#c as 'a) -> 'a end =
   struct let v x = ignore (x :> c); x end;;
+[%%expect{|
+type -'a t
+class type c = object method m : [ `A ] t end
+module M : sig val v : (#c as 'a) -> 'a end
+|}];;
 
 (* PR#4838 *)
 
 let id = let module M = struct end in fun x -> x;;
+[%%expect{|
+val id : 'a -> 'a = 
+|}];;
 
 (* PR#4511 *)
 
 let ko = let module M = struct end in fun _ -> ();;
+[%%expect{|
+val ko : 'a -> unit = 
+|}];;
 
 (* PR#5993 *)
 
 module M : sig type -'a t = private int end =
   struct type +'a t = private int end
 ;;
+[%%expect{|
+Line _, characters 2-37:
+Error: Signature mismatch:
+       Modules do not match:
+         sig type +'a t = private int end
+       is not included in
+         sig type -'a t = private int end
+       Type declarations do not match:
+         type +'a t = private int
+       is not included in
+         type -'a t = private int
+       Their variances do not agree.
+|}];;
 
 (* PR#6005 *)
 
 module type A = sig type t = X of int end;;
 type u = X of bool;;
 module type B = A with type t = u;; (* fail *)
+[%%expect{|
+module type A = sig type t = X of int end
+type u = X of bool
+Line _, characters 23-33:
+Error: This variant or record definition does not match that of type u
+       The types for field X are not equal.
+|}];;
 
 (* PR#5815 *)
 (* ---> duplicated exception name is now an error *)
 
 module type S = sig exception Foo of int  exception Foo of bool end;;
+[%%expect{|
+Line _, characters 52-55:
+Error: Multiple definition of the extension constructor name Foo.
+       Names must be unique in a given structure or signature.
+|}];;
 
 (* PR#6410 *)
 
 module F(X : sig end) = struct let x = 3 end;;
 F.x;; (* fail *)
+[%%expect{|
+module F : functor (X : sig  end) -> sig val x : int end
+Line _, characters 0-3:
+Error: The module F is a functor, not a structure
+|}];;
diff --git a/testsuite/tests/typing-modules/Test.ml.principal.reference b/testsuite/tests/typing-modules/Test.ml.principal.reference
deleted file mode 100644
index 9646d3d0..00000000
--- a/testsuite/tests/typing-modules/Test.ml.principal.reference
+++ /dev/null
@@ -1,41 +0,0 @@
-
-#     module type S = sig type t and s = t end
-# module type S' = sig type s = int end
-#   module type S = sig module rec M : sig  end and N : sig  end end
-# module type S' = sig module rec N : sig  end end
-#     * * * * * * * * * * * * * * * *         type -'a t
-class type c = object method m : [ `A ] t end
-#   module M : sig val v : (#c as 'a) -> 'a end
-#       val id : 'a -> 'a = 
-#       val ko : 'a -> unit = 
-#           Characters 64-99:
-    struct type +'a t = private int end
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Signature mismatch:
-       Modules do not match:
-         sig type +'a t = private int end
-       is not included in
-         sig type -'a t = private int end
-       Type declarations do not match:
-         type +'a t = private int
-       is not included in
-         type -'a t = private int
-       Their variances do not agree.
-#       module type A = sig type t = X of int end
-# type u = X of bool
-# Characters 23-33:
-  module type B = A with type t = u;; (* fail *)
-                         ^^^^^^^^^^
-Error: This variant or record definition does not match that of type u
-       The types for field X are not equal.
-#         Characters 121-124:
-  module type S = sig exception Foo of int  exception Foo of bool end;;
-                                                      ^^^
-Error: Multiple definition of the extension constructor name Foo.
-       Names must be unique in a given structure or signature.
-#       module F : functor (X : sig  end) -> sig val x : int end
-# Characters 0-3:
-  F.x;; (* fail *)
-  ^^^
-Error: The module F is a functor, not a structure
-# 
diff --git a/testsuite/tests/typing-modules/Test.ml.reference b/testsuite/tests/typing-modules/Test.ml.reference
deleted file mode 100644
index 9646d3d0..00000000
--- a/testsuite/tests/typing-modules/Test.ml.reference
+++ /dev/null
@@ -1,41 +0,0 @@
-
-#     module type S = sig type t and s = t end
-# module type S' = sig type s = int end
-#   module type S = sig module rec M : sig  end and N : sig  end end
-# module type S' = sig module rec N : sig  end end
-#     * * * * * * * * * * * * * * * *         type -'a t
-class type c = object method m : [ `A ] t end
-#   module M : sig val v : (#c as 'a) -> 'a end
-#       val id : 'a -> 'a = 
-#       val ko : 'a -> unit = 
-#           Characters 64-99:
-    struct type +'a t = private int end
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Signature mismatch:
-       Modules do not match:
-         sig type +'a t = private int end
-       is not included in
-         sig type -'a t = private int end
-       Type declarations do not match:
-         type +'a t = private int
-       is not included in
-         type -'a t = private int
-       Their variances do not agree.
-#       module type A = sig type t = X of int end
-# type u = X of bool
-# Characters 23-33:
-  module type B = A with type t = u;; (* fail *)
-                         ^^^^^^^^^^
-Error: This variant or record definition does not match that of type u
-       The types for field X are not equal.
-#         Characters 121-124:
-  module type S = sig exception Foo of int  exception Foo of bool end;;
-                                                      ^^^
-Error: Multiple definition of the extension constructor name Foo.
-       Names must be unique in a given structure or signature.
-#       module F : functor (X : sig  end) -> sig val x : int end
-# Characters 0-3:
-  F.x;; (* fail *)
-  ^^^
-Error: The module F is a functor, not a structure
-# 
diff --git a/testsuite/tests/typing-modules/a.mli b/testsuite/tests/typing-modules/a.mli
deleted file mode 100644
index ea15bf00..00000000
--- a/testsuite/tests/typing-modules/a.mli
+++ /dev/null
@@ -1,3 +0,0 @@
-module L = List
-module S = String
-module D' = D
diff --git a/testsuite/tests/typing-modules/aliases.ml b/testsuite/tests/typing-modules/aliases.ml
index 7580bebe..b318543e 100644
--- a/testsuite/tests/typing-modules/aliases.ml
+++ b/testsuite/tests/typing-modules/aliases.ml
@@ -6,22 +6,100 @@ C'.chr 66;;
 
 module C3 = struct include Char end;;
 C3.chr 66;;
+[%%expect{|
+module C = Char
+- : char = 'B'
+module C' :
+  sig
+    external code : char -> int = "%identity"
+    val chr : int -> char
+    val escaped : char -> string
+    val lowercase : char -> char
+    val uppercase : char -> char
+    val lowercase_ascii : char -> char
+    val uppercase_ascii : char -> char
+    type t = char
+    val compare : t -> t -> int
+    val equal : t -> t -> bool
+    external unsafe_chr : int -> char = "%identity"
+  end
+- : char = 'B'
+module C3 :
+  sig
+    external code : char -> int = "%identity"
+    val chr : int -> char
+    val escaped : char -> string
+    val lowercase : char -> char
+    val uppercase : char -> char
+    val lowercase_ascii : char -> char
+    val uppercase_ascii : char -> char
+    type t = char
+    val compare : t -> t -> int
+    val equal : t -> t -> bool
+    external unsafe_chr : int -> char = "%identity"
+  end
+- : char = 'B'
+|}];;
 
 let f x = let module M = struct module L = List end in M.L.length x;;
 let g x = let module L = List in L.length (L.map succ x);;
+[%%expect{|
+val f : 'a list -> int = 
+val g : int list -> int = 
+|}];;
 
 module F(X:sig end) = Char;;
 module C4 = F(struct end);;
 C4.chr 66;;
+[%%expect{|
+module F :
+  functor (X : sig  end) ->
+    sig
+      external code : char -> int = "%identity"
+      val chr : int -> char
+      val escaped : char -> string
+      val lowercase : char -> char
+      val uppercase : char -> char
+      val lowercase_ascii : char -> char
+      val uppercase_ascii : char -> char
+      type t = char
+      val compare : t -> t -> int
+      val equal : t -> t -> bool
+      external unsafe_chr : int -> char = "%identity"
+    end
+module C4 :
+  sig
+    external code : char -> int = "%identity"
+    val chr : int -> char
+    val escaped : char -> string
+    val lowercase : char -> char
+    val uppercase : char -> char
+    val lowercase_ascii : char -> char
+    val uppercase_ascii : char -> char
+    type t = char
+    val compare : t -> t -> int
+    val equal : t -> t -> bool
+    external unsafe_chr : int -> char = "%identity"
+  end
+- : char = 'B'
+|}];;
 
 module G(X:sig end) = struct module M = X end;; (* does not alias X *)
 module M = G(struct end);;
+[%%expect{|
+module G : functor (X : sig  end) -> sig module M : sig  end end
+module M : sig module M : sig  end end
+|}];;
 
 module M' = struct
   module N = struct let x = 1 end
   module N' = N
 end;;
 M'.N'.x;;
+[%%expect{|
+module M' : sig module N : sig val x : int end module N' = N end
+- : int = 1
+|}];;
 
 module M'' : sig module N' : sig val x : int end end = M';;
 M''.N'.x;;
@@ -30,12 +108,25 @@ module M3 : sig module N' : sig val x : int end end = struct include M' end;;
 M3.N'.x;;
 module M3' : sig module N' : sig val x : int end end = M2;;
 M3'.N'.x;;
+[%%expect{|
+module M'' : sig module N' : sig val x : int end end
+- : int = 1
+module M2 : sig module N = M'.N module N' = N end
+module M3 : sig module N' : sig val x : int end end
+- : int = 1
+module M3' : sig module N' : sig val x : int end end
+- : int = 1
+|}];;
 
 module M4 : sig module N' : sig val x : int end end = struct
   module N = struct let x = 1 end
   module N' = N
 end;;
 M4.N'.x;;
+[%%expect{|
+module M4 : sig module N' : sig val x : int end end
+- : int = 1
+|}];;
 
 module F(X:sig end) = struct
   module N = struct let x = 1 end
@@ -44,6 +135,14 @@ end;;
 module G : functor(X:sig end) -> sig module N' : sig val x : int end end = F;;
 module M5 = G(struct end);;
 M5.N'.x;;
+[%%expect{|
+module F :
+  functor (X : sig  end) ->
+    sig module N : sig val x : int end module N' = N end
+module G : functor (X : sig  end) -> sig module N' : sig val x : int end end
+module M5 : sig module N' : sig val x : int end end
+- : int = 1
+|}];;
 
 module M = struct
   module D = struct let y = 3 end
@@ -59,6 +158,19 @@ M2.N'.x;;
 
 open M;;
 N'.x;;
+[%%expect{|
+module M :
+  sig
+    module D : sig val y : int end
+    module N : sig val x : int end
+    module N' = N
+  end
+module M1 : sig module N : sig val x : int end module N' = N end
+- : int = 1
+module M2 : sig module N' : sig val x : int end end
+- : int = 1
+- : int = 1
+|}];;
 
 module M = struct
   module C = Char
@@ -71,12 +183,28 @@ M1.C'.escaped 'A';;
 module M2 : sig module C' : sig val chr : int -> char end end =
   (M : sig module C : sig val chr : int -> char end module C' = C end);;
 M2.C'.chr 66;;
+[%%expect{|
+module M : sig module C = Char module C' = C end
+module M1 :
+  sig module C : sig val escaped : char -> string end module C' = C end
+- : string = "A"
+module M2 : sig module C' : sig val chr : int -> char end end
+- : char = 'B'
+|}];;
 
 StdLabels.List.map;;
+[%%expect{|
+- : f:('a -> 'b) -> 'a list -> 'b list = 
+|}];;
 
 module Q = Queue;;
 exception QE = Q.Empty;;
 try Q.pop (Q.create ()) with QE -> "Ok";;
+[%%expect{|
+module Q = Queue
+exception QE
+- : string = "Ok"
+|}];;
 
 module type Complex = module type of Complex with type t = Complex.t;;
 module M : sig module C : Complex end = struct module C = Complex end;;
@@ -84,14 +212,131 @@ module M : sig module C : Complex end = struct module C = Complex end;;
 module C = Complex;;
 C.one.Complex.re;;
 include C;;
+[%%expect{|
+module type Complex =
+  sig
+    type t = Complex.t = { re : float; im : float; }
+    val zero : t
+    val one : t
+    val i : t
+    val neg : t -> t
+    val conj : t -> t
+    val add : t -> t -> t
+    val sub : t -> t -> t
+    val mul : t -> t -> t
+    val inv : t -> t
+    val div : t -> t -> t
+    val sqrt : t -> t
+    val norm2 : t -> float
+    val norm : t -> float
+    val arg : t -> float
+    val polar : float -> float -> t
+    val exp : t -> t
+    val log : t -> t
+    val pow : t -> t -> t
+  end
+module M : sig module C : Complex end
+module C = Complex
+- : float = 1.
+type t = Complex.t = { re : float; im : float; }
+val zero : t = {re = 0.; im = 0.}
+val one : t = {re = 1.; im = 0.}
+val i : t = {re = 0.; im = 1.}
+val neg : t -> t = 
+val conj : t -> t = 
+val add : t -> t -> t = 
+val sub : t -> t -> t = 
+val mul : t -> t -> t = 
+val inv : t -> t = 
+val div : t -> t -> t = 
+val sqrt : t -> t = 
+val norm2 : t -> float = 
+val norm : t -> float = 
+val arg : t -> float = 
+val polar : float -> float -> t = 
+val exp : t -> t = 
+val log : t -> t = 
+val pow : t -> t -> t = 
+|}];;
 
 module F(X:sig module C = Char end) = struct module C = X.C end;;
+[%%expect{|
+module F : functor (X : sig module C = Char end) -> sig module C = Char end
+|}];;
 
 (* Applicative functors *)
 module S = String
 module StringSet = Set.Make(String)
 module SSet = Set.Make(S);;
 let f (x : StringSet.t) = (x : SSet.t);;
+[%%expect{|
+module S = String
+module StringSet :
+  sig
+    type elt = String.t
+    type t = Set.Make(String).t
+    val empty : t
+    val is_empty : t -> bool
+    val mem : elt -> t -> bool
+    val add : elt -> t -> t
+    val singleton : elt -> t
+    val remove : elt -> t -> t
+    val union : t -> t -> t
+    val inter : t -> t -> t
+    val diff : t -> t -> t
+    val compare : t -> t -> int
+    val equal : t -> t -> bool
+    val subset : t -> t -> bool
+    val iter : (elt -> unit) -> t -> unit
+    val map : (elt -> elt) -> t -> t
+    val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
+    val for_all : (elt -> bool) -> t -> bool
+    val exists : (elt -> bool) -> t -> bool
+    val filter : (elt -> bool) -> t -> t
+    val partition : (elt -> bool) -> t -> t * t
+    val cardinal : t -> int
+    val elements : t -> elt list
+    val min_elt : t -> elt
+    val max_elt : t -> elt
+    val choose : t -> elt
+    val split : elt -> t -> t * bool * t
+    val find : elt -> t -> elt
+    val of_list : elt list -> t
+  end
+module SSet :
+  sig
+    type elt = S.t
+    type t = Set.Make(S).t
+    val empty : t
+    val is_empty : t -> bool
+    val mem : elt -> t -> bool
+    val add : elt -> t -> t
+    val singleton : elt -> t
+    val remove : elt -> t -> t
+    val union : t -> t -> t
+    val inter : t -> t -> t
+    val diff : t -> t -> t
+    val compare : t -> t -> int
+    val equal : t -> t -> bool
+    val subset : t -> t -> bool
+    val iter : (elt -> unit) -> t -> unit
+    val map : (elt -> elt) -> t -> t
+    val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
+    val for_all : (elt -> bool) -> t -> bool
+    val exists : (elt -> bool) -> t -> bool
+    val filter : (elt -> bool) -> t -> t
+    val partition : (elt -> bool) -> t -> t * t
+    val cardinal : t -> int
+    val elements : t -> elt list
+    val min_elt : t -> elt
+    val max_elt : t -> elt
+    val choose : t -> elt
+    val split : elt -> t -> t * bool * t
+    val find : elt -> t -> elt
+    val of_list : elt list -> t
+  end
+val f : StringSet.t -> SSet.t = 
+|}];;
 
 (* Also using include (cf. Leo's mail 2013-11-16) *)
 module F (M : sig end) : sig type t end = struct type t = int end
@@ -101,6 +346,13 @@ module T = struct
 end;;
 include T;;
 let f (x : t) : T.t = x ;;
+[%%expect{|
+module F : functor (M : sig  end) -> sig type t end
+module T : sig module M : sig  end type t = F(M).t end
+module M = T.M
+type t = F(M).t
+val f : t -> T.t = 
+|}];;
 
 (* PR#4049 *)
 (* This works thanks to abbreviations *)
@@ -111,6 +363,47 @@ module A = struct
 end
 module A1 = A;;
 A1.empty = A.empty;;
+[%%expect{|
+module A :
+  sig
+    module B : sig type t val compare : 'a -> 'b -> int end
+    module S :
+      sig
+        type elt = B.t
+        type t = Set.Make(B).t
+        val empty : t
+        val is_empty : t -> bool
+        val mem : elt -> t -> bool
+        val add : elt -> t -> t
+        val singleton : elt -> t
+        val remove : elt -> t -> t
+        val union : t -> t -> t
+        val inter : t -> t -> t
+        val diff : t -> t -> t
+        val compare : t -> t -> int
+        val equal : t -> t -> bool
+        val subset : t -> t -> bool
+        val iter : (elt -> unit) -> t -> unit
+        val map : (elt -> elt) -> t -> t
+        val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
+        val for_all : (elt -> bool) -> t -> bool
+        val exists : (elt -> bool) -> t -> bool
+        val filter : (elt -> bool) -> t -> t
+        val partition : (elt -> bool) -> t -> t * t
+        val cardinal : t -> int
+        val elements : t -> elt list
+        val min_elt : t -> elt
+        val max_elt : t -> elt
+        val choose : t -> elt
+        val split : elt -> t -> t * bool * t
+        val find : elt -> t -> elt
+        val of_list : elt list -> t
+      end
+    val empty : S.t
+  end
+module A1 = A
+- : bool = true
+|}];;
 
 (* PR#3476 *)
 (* Does not work yet *)
@@ -125,6 +418,18 @@ module F (Y : sig type t end) (M : sig type t = Y.t end) = struct end;;
 module G = F (M.Y);;
 (*module N = G (M);;
 module N = F (M.Y) (M);;*)
+[%%expect{|
+module FF : functor (X : sig  end) -> sig type t end
+module M :
+  sig
+    module X : sig  end
+    module Y : sig type t = FF(X).t end
+    type t = Y.t
+  end
+module F :
+  functor (Y : sig type t end) (M : sig type t = Y.t end) -> sig  end
+module G : functor (M : sig type t = M.Y.t end) -> sig  end
+|}];;
 
 (* PR#6307 *)
 
@@ -137,6 +442,15 @@ module F (L : (module type of L1)) = struct end;;
 
 module F1 = F(L1);; (* ok *)
 module F2 = F(L2);; (* should succeed too *)
+[%%expect{|
+module A1 : sig  end
+module A2 : sig  end
+module L1 : sig module X = A1 end
+module L2 : sig module X = A2 end
+module F : functor (L : sig module X : sig  end end) -> sig  end
+module F1 : sig  end
+module F2 : sig  end
+|}];;
 
 (* Counter example: why we need to be careful with PR#6307 *)
 module Int = struct type t = int let compare = compare end
@@ -155,6 +469,58 @@ module type S' = sig
   module I = Int2
   include S with module I := I
 end;; (* fail *)
+[%%expect{|
+module Int : sig type t = int val compare : 'a -> 'a -> int end
+module SInt :
+  sig
+    type elt = Int.t
+    type t = Set.Make(Int).t
+    val empty : t
+    val is_empty : t -> bool
+    val mem : elt -> t -> bool
+    val add : elt -> t -> t
+    val singleton : elt -> t
+    val remove : elt -> t -> t
+    val union : t -> t -> t
+    val inter : t -> t -> t
+    val diff : t -> t -> t
+    val compare : t -> t -> int
+    val equal : t -> t -> bool
+    val subset : t -> t -> bool
+    val iter : (elt -> unit) -> t -> unit
+    val map : (elt -> elt) -> t -> t
+    val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
+    val for_all : (elt -> bool) -> t -> bool
+    val exists : (elt -> bool) -> t -> bool
+    val filter : (elt -> bool) -> t -> t
+    val partition : (elt -> bool) -> t -> t * t
+    val cardinal : t -> int
+    val elements : t -> elt list
+    val min_elt : t -> elt
+    val max_elt : t -> elt
+    val choose : t -> elt
+    val split : elt -> t -> t * bool * t
+    val find : elt -> t -> elt
+    val of_list : elt list -> t
+  end
+type (_, _) eq = Eq : ('a, 'a) eq
+type wrap = W of (SInt.t, SInt.t) eq
+module M :
+  sig
+    module I = Int
+    type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(I).t) eq
+  end
+module type S =
+  sig
+    module I = Int
+    type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(I).t) eq
+  end
+module Int2 : sig type t = int val compare : 'a -> 'a -> int end
+Line _, characters 10-30:
+Error: In this `with' constraint, the new definition of I
+       does not match its original definition in the constrained signature:
+       Modules do not match: (module Int2) is not included in (module Int)
+|}];;
 
 (* (* if the above succeeded, one could break invariants *)
 module rec M2 : S' = M2;; (* should succeed! (but this is bad) *)
@@ -178,6 +544,22 @@ module M = struct
   end
 end;;
 module type S = module type of M ;;
+[%%expect{|
+module M :
+  sig
+    module N : sig module I = Int end
+    module P : sig module I = N.I end
+    module Q :
+      sig type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(P.I).t) eq end
+  end
+module type S =
+  sig
+    module N : sig module I = Int end
+    module P : sig module I = N.I end
+    module Q :
+      sig type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(P.I).t) eq end
+  end
+|}];;
 
 module M = struct
   module N = struct module I = Int end
@@ -187,18 +569,57 @@ module M = struct
   end
 end;;
 module type S = module type of M ;;
+[%%expect{|
+module M :
+  sig
+    module N : sig module I = Int end
+    module P : sig module I = N.I end
+    module Q :
+      sig type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(N.I).t) eq end
+  end
+module type S =
+  sig
+    module N : sig module I = Int end
+    module P :
+      sig module I : sig type t = int val compare : 'a -> 'a -> int end end
+    module Q :
+      sig type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(N.I).t) eq end
+  end
+|}];;
 
 (* PR#6365 *)
 module type S = sig module M : sig type t val x : t end end;;
 module H = struct type t = A let x = A end;;
 module H' = H;;
 module type S' = S with module M = H';; (* shouldn't introduce an alias *)
+[%%expect{|
+module type S = sig module M : sig type t val x : t end end
+module H : sig type t = A val x : t end
+module H' = H
+module type S' = sig module M : sig type t = H.t = A val x : t end end
+|}];;
 
 (* PR#6376 *)
 module type Alias = sig module N : sig end module M = N end;;
 module F (X : sig end) = struct type t end;;
 module type A = Alias with module N := F(List);;
 module rec Bad : A = Bad;;
+[%%expect{|
+module type Alias = sig module N : sig  end module M = N end
+module F : functor (X : sig  end) -> sig type t end
+Line _:
+Error: Module type declarations do not match:
+         module type A = sig module M = F(List) end
+       does not match
+         module type A = sig module M = F(List) end
+       At position module type A = 
+       Modules do not match:
+         sig module M = F(List) end
+       is not included in
+         sig module M = F(List) end
+       At position module type A = sig module M :  end
+       Module F(List) cannot be aliased
+|}];;
 
 (* Shinwell 2014-04-23 *)
 module B = struct
@@ -215,17 +636,30 @@ module K = struct
 end;;
 
 let x : K.N.t = "foo";;
+[%%expect{|
+module B : sig module R : sig type t = string end module O = R end
+module K : sig module E = B module N = E.O end
+val x : K.N.t = "foo"
+|}];;
 
 (* PR#6465 *)
 
 module M = struct type t = A module B = struct type u = B end end;;
-module P : sig type t = M.t = A module B = M.B end = M;; (* should be ok *)
+module P : sig type t = M.t = A module B = M.B end = M;;
 module P : sig type t = M.t = A module B = M.B end = struct include M end;;
+[%%expect{|
+module M : sig type t = A module B : sig type u = B end end
+module P : sig type t = M.t = A module B = M.B end
+module P : sig type t = M.t = A module B = M.B end
+|}];;
 
 module type S = sig
   module M : sig module P : sig end end
   module Q = M
 end;;
+[%%expect{|
+module type S = sig module M : sig module P : sig  end end module Q = M end
+|}];;
 module type S = sig
   module M : sig module N : sig end module P : sig end end
   module Q : sig module N = M.N module P = M.P end
@@ -234,7 +668,40 @@ module R = struct
   module M = struct module N = struct end module P = struct end end
   module Q = M
 end;;
-module R' : S = R;; (* should be ok *)
+module R' : S = R;;
+[%%expect{|
+module type S =
+  sig
+    module M : sig module N : sig  end module P : sig  end end
+    module Q : sig module N = M.N module P = M.P end
+  end
+module R :
+  sig
+    module M : sig module N : sig  end module P : sig  end end
+    module Q = M
+  end
+module R' : S
+|}];;
+
+module F (X : sig end) = struct type t end;;
+module M : sig
+  type a
+  module Foo : sig
+    module Bar : sig end
+    type b = a
+  end
+end = struct
+  module Foo = struct
+    module Bar = struct end
+    type b = F(Bar).t
+  end
+  type a = Foo.b
+end;;
+[%%expect{|
+module F : functor (X : sig  end) -> sig type t end
+module M :
+  sig type a module Foo : sig module Bar : sig  end type b = a end end
+|}];;
 
 (* PR#6578 *)
 
@@ -242,5 +709,14 @@ module M = struct let f x = x end
 module rec R : sig module M : sig val f : 'a -> 'a end end =
   struct module M = M end;;
 R.M.f 3;;
+[%%expect{|
+module M : sig val f : 'a -> 'a end
+module rec R : sig module M : sig val f : 'a -> 'a end end
+- : int = 3
+|}];;
 module rec R : sig module M = M end = struct module M = M end;;
 R.M.f 3;;
+[%%expect{|
+module rec R : sig module M = M end
+- : int = 3
+|}];;
diff --git a/testsuite/tests/typing-modules/aliases.ml.reference b/testsuite/tests/typing-modules/aliases.ml.reference
deleted file mode 100644
index 724f0138..00000000
--- a/testsuite/tests/typing-modules/aliases.ml.reference
+++ /dev/null
@@ -1,402 +0,0 @@
-
-# module C = Char
-# - : char = 'B'
-#   module C' :
-  sig
-    external code : char -> int = "%identity"
-    val chr : int -> char
-    val escaped : char -> string
-    val lowercase : char -> char
-    val uppercase : char -> char
-    val lowercase_ascii : char -> char
-    val uppercase_ascii : char -> char
-    type t = char
-    val compare : t -> t -> int
-    val equal : t -> t -> bool
-    external unsafe_chr : int -> char = "%identity"
-  end
-# - : char = 'B'
-#   module C3 :
-  sig
-    external code : char -> int = "%identity"
-    val chr : int -> char
-    val escaped : char -> string
-    val lowercase : char -> char
-    val uppercase : char -> char
-    val lowercase_ascii : char -> char
-    val uppercase_ascii : char -> char
-    type t = char
-    val compare : t -> t -> int
-    val equal : t -> t -> bool
-    external unsafe_chr : int -> char = "%identity"
-  end
-# - : char = 'B'
-#   val f : 'a list -> int = 
-# val g : int list -> int = 
-#   module F :
-  functor (X : sig  end) ->
-    sig
-      external code : char -> int = "%identity"
-      val chr : int -> char
-      val escaped : char -> string
-      val lowercase : char -> char
-      val uppercase : char -> char
-      val lowercase_ascii : char -> char
-      val uppercase_ascii : char -> char
-      type t = char
-      val compare : t -> t -> int
-      val equal : t -> t -> bool
-      external unsafe_chr : int -> char = "%identity"
-    end
-# module C4 :
-  sig
-    external code : char -> int = "%identity"
-    val chr : int -> char
-    val escaped : char -> string
-    val lowercase : char -> char
-    val uppercase : char -> char
-    val lowercase_ascii : char -> char
-    val uppercase_ascii : char -> char
-    type t = char
-    val compare : t -> t -> int
-    val equal : t -> t -> bool
-    external unsafe_chr : int -> char = "%identity"
-  end
-# - : char = 'B'
-#   module G : functor (X : sig  end) -> sig module M : sig  end end
-# module M : sig module M : sig  end end
-#         module M' : sig module N : sig val x : int end module N' = N end
-# - : int = 1
-#   module M'' : sig module N' : sig val x : int end end
-# - : int = 1
-# module M2 : sig module N = M'.N module N' = M'.N' end
-# module M3 : sig module N' : sig val x : int end end
-# - : int = 1
-# module M3' : sig module N' : sig val x : int end end
-# - : int = 1
-#         module M4 : sig module N' : sig val x : int end end
-# - : int = 1
-#         module F :
-  functor (X : sig  end) ->
-    sig module N : sig val x : int end module N' = N end
-# module G : functor (X : sig  end) -> sig module N' : sig val x : int end end
-# module M5 : sig module N' : sig val x : int end end
-# - : int = 1
-#           module M :
-  sig
-    module D : sig val y : int end
-    module N : sig val x : int end
-    module N' = N
-  end
-#   module M1 : sig module N : sig val x : int end module N' = N end
-# - : int = 1
-#   module M2 : sig module N' : sig val x : int end end
-# - : int = 1
-#   # - : int = 1
-#         module M : sig module C = Char module C' = C end
-#     module M1 :
-  sig module C : sig val escaped : char -> string end module C' = C end
-# - : string = "A"
-#   module M2 : sig module C' : sig val chr : int -> char end end
-# - : char = 'B'
-#   - : f:('a -> 'b) -> 'a list -> 'b list = 
-#   module Q = Queue
-# exception QE
-# - : string = "Ok"
-#   module type Complex =
-  sig
-    type t = Complex.t = { re : float; im : float; }
-    val zero : t
-    val one : t
-    val i : t
-    val neg : t -> t
-    val conj : t -> t
-    val add : t -> t -> t
-    val sub : t -> t -> t
-    val mul : t -> t -> t
-    val inv : t -> t
-    val div : t -> t -> t
-    val sqrt : t -> t
-    val norm2 : t -> float
-    val norm : t -> float
-    val arg : t -> float
-    val polar : float -> float -> t
-    val exp : t -> t
-    val log : t -> t
-    val pow : t -> t -> t
-  end
-# module M : sig module C : Complex end
-#   module C = Complex
-# - : float = 1.
-# type t = Complex.t = { re : float; im : float; }
-val zero : t = {re = 0.; im = 0.}
-val one : t = {re = 1.; im = 0.}
-val i : t = {re = 0.; im = 1.}
-val neg : t -> t = 
-val conj : t -> t = 
-val add : t -> t -> t = 
-val sub : t -> t -> t = 
-val mul : t -> t -> t = 
-val inv : t -> t = 
-val div : t -> t -> t = 
-val sqrt : t -> t = 
-val norm2 : t -> float = 
-val norm : t -> float = 
-val arg : t -> float = 
-val polar : float -> float -> t = 
-val exp : t -> t = 
-val log : t -> t = 
-val pow : t -> t -> t = 
-#   module F : functor (X : sig module C = Char end) -> sig module C = Char end
-#         module S = String
-module StringSet :
-  sig
-    type elt = String.t
-    type t = Set.Make(String).t
-    val empty : t
-    val is_empty : t -> bool
-    val mem : elt -> t -> bool
-    val add : elt -> t -> t
-    val singleton : elt -> t
-    val remove : elt -> t -> t
-    val union : t -> t -> t
-    val inter : t -> t -> t
-    val diff : t -> t -> t
-    val compare : t -> t -> int
-    val equal : t -> t -> bool
-    val subset : t -> t -> bool
-    val iter : (elt -> unit) -> t -> unit
-    val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
-    val for_all : (elt -> bool) -> t -> bool
-    val exists : (elt -> bool) -> t -> bool
-    val filter : (elt -> bool) -> t -> t
-    val partition : (elt -> bool) -> t -> t * t
-    val cardinal : t -> int
-    val elements : t -> elt list
-    val min_elt : t -> elt
-    val max_elt : t -> elt
-    val choose : t -> elt
-    val split : elt -> t -> t * bool * t
-    val find : elt -> t -> elt
-    val of_list : elt list -> t
-  end
-module SSet :
-  sig
-    type elt = S.t
-    type t = Set.Make(S).t
-    val empty : t
-    val is_empty : t -> bool
-    val mem : elt -> t -> bool
-    val add : elt -> t -> t
-    val singleton : elt -> t
-    val remove : elt -> t -> t
-    val union : t -> t -> t
-    val inter : t -> t -> t
-    val diff : t -> t -> t
-    val compare : t -> t -> int
-    val equal : t -> t -> bool
-    val subset : t -> t -> bool
-    val iter : (elt -> unit) -> t -> unit
-    val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
-    val for_all : (elt -> bool) -> t -> bool
-    val exists : (elt -> bool) -> t -> bool
-    val filter : (elt -> bool) -> t -> t
-    val partition : (elt -> bool) -> t -> t * t
-    val cardinal : t -> int
-    val elements : t -> elt list
-    val min_elt : t -> elt
-    val max_elt : t -> elt
-    val choose : t -> elt
-    val split : elt -> t -> t * bool * t
-    val find : elt -> t -> elt
-    val of_list : elt list -> t
-  end
-# val f : StringSet.t -> SSet.t = 
-#             module F : functor (M : sig  end) -> sig type t end
-module T : sig module M : sig  end type t = F(M).t end
-# module M = T.M
-type t = F(M).t
-# val f : t -> T.t = 
-#                 module A :
-  sig
-    module B : sig type t val compare : 'a -> 'b -> int end
-    module S :
-      sig
-        type elt = B.t
-        type t = Set.Make(B).t
-        val empty : t
-        val is_empty : t -> bool
-        val mem : elt -> t -> bool
-        val add : elt -> t -> t
-        val singleton : elt -> t
-        val remove : elt -> t -> t
-        val union : t -> t -> t
-        val inter : t -> t -> t
-        val diff : t -> t -> t
-        val compare : t -> t -> int
-        val equal : t -> t -> bool
-        val subset : t -> t -> bool
-        val iter : (elt -> unit) -> t -> unit
-        val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
-        val for_all : (elt -> bool) -> t -> bool
-        val exists : (elt -> bool) -> t -> bool
-        val filter : (elt -> bool) -> t -> t
-        val partition : (elt -> bool) -> t -> t * t
-        val cardinal : t -> int
-        val elements : t -> elt list
-        val min_elt : t -> elt
-        val max_elt : t -> elt
-        val choose : t -> elt
-        val split : elt -> t -> t * bool * t
-        val find : elt -> t -> elt
-        val of_list : elt list -> t
-      end
-    val empty : S.t
-  end
-module A1 = A
-# - : bool = true
-#                   module FF : functor (X : sig  end) -> sig type t end
-module M :
-  sig
-    module X : sig  end
-    module Y : sig type t = FF(X).t end
-    type t = Y.t
-  end
-module F :
-  functor (Y : sig type t end) (M : sig type t = Y.t end) -> sig  end
-#   module G : functor (M : sig type t = M.Y.t end) -> sig  end
-# *               module A1 : sig  end
-module A2 : sig  end
-module L1 : sig module X = A1 end
-module L2 : sig module X = A2 end
-#   module F : functor (L : sig module X : sig  end end) -> sig  end
-#   module F1 : sig  end
-# module F2 : sig  end
-#                     module Int : sig type t = int val compare : 'a -> 'a -> int end
-module SInt :
-  sig
-    type elt = Int.t
-    type t = Set.Make(Int).t
-    val empty : t
-    val is_empty : t -> bool
-    val mem : elt -> t -> bool
-    val add : elt -> t -> t
-    val singleton : elt -> t
-    val remove : elt -> t -> t
-    val union : t -> t -> t
-    val inter : t -> t -> t
-    val diff : t -> t -> t
-    val compare : t -> t -> int
-    val equal : t -> t -> bool
-    val subset : t -> t -> bool
-    val iter : (elt -> unit) -> t -> unit
-    val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
-    val for_all : (elt -> bool) -> t -> bool
-    val exists : (elt -> bool) -> t -> bool
-    val filter : (elt -> bool) -> t -> t
-    val partition : (elt -> bool) -> t -> t * t
-    val cardinal : t -> int
-    val elements : t -> elt list
-    val min_elt : t -> elt
-    val max_elt : t -> elt
-    val choose : t -> elt
-    val split : elt -> t -> t * bool * t
-    val find : elt -> t -> elt
-    val of_list : elt list -> t
-  end
-type (_, _) eq = Eq : ('a, 'a) eq
-type wrap = W of (SInt.t, SInt.t) eq
-module M :
-  sig
-    module I = Int
-    type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(I).t) eq
-  end
-# module type S =
-  sig
-    module I = Int
-    type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(I).t) eq
-  end
-#   module Int2 : sig type t = int val compare : 'a -> 'a -> int end
-#       Characters 49-69:
-    include S with module I := I
-            ^^^^^^^^^^^^^^^^^^^^
-Error: In this `with' constraint, the new definition of I
-       does not match its original definition in the constrained signature:
-       Modules do not match: (module Int2) is not included in (module Int)
-#   * * * * * * * * * * *                   module M :
-  sig
-    module N : sig module I = Int end
-    module P : sig module I = N.I end
-    module Q :
-      sig type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(P.I).t) eq end
-  end
-# module type S =
-  sig
-    module N : sig module I = Int end
-    module P : sig module I = N.I end
-    module Q :
-      sig type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(P.I).t) eq end
-  end
-#               module M :
-  sig
-    module N : sig module I = Int end
-    module P : sig module I = N.I end
-    module Q :
-      sig type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(N.I).t) eq end
-  end
-# module type S =
-  sig
-    module N : sig module I = Int end
-    module P :
-      sig module I : sig type t = int val compare : 'a -> 'a -> int end end
-    module Q :
-      sig type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(N.I).t) eq end
-  end
-#     module type S = sig module M : sig type t val x : t end end
-# module H : sig type t = A val x : t end
-# module H' = H
-# module type S' = sig module M : sig type t = H.t = A val x : t end end
-#     module type Alias = sig module N : sig  end module M = N end
-# module F : functor (X : sig  end) -> sig type t end
-# Characters -1--1:
-  module type A = Alias with module N := F(List);;
-  
-Error: Module type declarations do not match:
-         module type A = sig module M = F(List) end
-       does not match
-         module type A = sig module M = F(List) end
-       At position module type A = 
-       Modules do not match:
-         sig module M = F(List) end
-       is not included in
-         sig module M = F(List) end
-       At position module type A = sig module M :  end
-       Module F(List) cannot be aliased
-# Characters 17-18:
-  module rec Bad : A = Bad;;
-                   ^
-Error: Unbound module type A
-#                           module B : sig module R : sig type t = string end module O = R end
-module K : sig module E = B module N = E.O end
-#   val x : K.N.t = "foo"
-#       module M : sig type t = A module B : sig type u = B end end
-# module P : sig type t = M.t = A module B = M.B end
-# module P : sig type t = M.t = A module B = M.B end
-#         module type S = sig module M : sig module P : sig  end end module Q = M end
-#       module type S =
-  sig
-    module M : sig module N : sig  end module P : sig  end end
-    module Q : sig module N = M.N module P = M.P end
-  end
-#       module R :
-  sig
-    module M : sig module N : sig  end module P : sig  end end
-    module Q = M
-  end
-# module R' : S
-#           module M : sig val f : 'a -> 'a end
-module rec R : sig module M : sig val f : 'a -> 'a end end
-# - : int = 3
-# module rec R : sig module M = M end
-# - : int = 3
-# 
diff --git a/testsuite/tests/typing-modules/b.ml b/testsuite/tests/typing-modules/b.ml
deleted file mode 100644
index 4c43e809..00000000
--- a/testsuite/tests/typing-modules/b.ml
+++ /dev/null
@@ -1,18 +0,0 @@
-open A
-let f =
-  L.map S.capitalize
-
-let () =
-  L.iter print_endline (f ["jacques"; "garrigue"])
-
-module C : sig module L : module type of List end = struct include A end
-
-(* The following introduces a (useless) dependency on A:
-module C : sig module L : module type of List end = A
-*)
-
-include D'
-(*
-let () =
-  print_endline (string_of_int D'.M.y)
-*)
diff --git a/testsuite/tests/typing-modules/b.ml.reference b/testsuite/tests/typing-modules/b.ml.reference
deleted file mode 100644
index 9faafbf6..00000000
--- a/testsuite/tests/typing-modules/b.ml.reference
+++ /dev/null
@@ -1,5 +0,0 @@
-
-#                   * *       * * *   
-Characters 352-352:
-  Error: Syntax error
-# 
diff --git a/testsuite/tests/typing-modules/b2.ml b/testsuite/tests/typing-modules/b2.ml
deleted file mode 100644
index 034e432c..00000000
--- a/testsuite/tests/typing-modules/b2.ml
+++ /dev/null
@@ -1,14 +0,0 @@
-open A
-let f =
-  L.map S.capitalize
-
-let () =
-  L.iter print_endline (f ["jacques"; "garrigue"])
-
-module C : sig module L : module type of List end = struct include A end
-
-(* The following introduces a (useless) dependency on A:
-module C : sig module L : module type of List end = A
-*)
-
-(* No dependency on D *)
diff --git a/testsuite/tests/typing-modules/b2.ml.reference b/testsuite/tests/typing-modules/b2.ml.reference
deleted file mode 100644
index 9b455862..00000000
--- a/testsuite/tests/typing-modules/b2.ml.reference
+++ /dev/null
@@ -1,5 +0,0 @@
-
-#                   * *       
-Characters 312-312:
-  Error: Syntax error
-# 
diff --git a/testsuite/tests/typing-modules/b3.mli b/testsuite/tests/typing-modules/b3.mli
deleted file mode 100644
index 04599abe..00000000
--- a/testsuite/tests/typing-modules/b3.mli
+++ /dev/null
@@ -1,4 +0,0 @@
-open A
-(*module type S = module type of D'.M*)
-type t = Complex.t
-type s = String.t
diff --git a/testsuite/tests/typing-modules/d.ml b/testsuite/tests/typing-modules/d.ml
deleted file mode 100644
index 55d311f4..00000000
--- a/testsuite/tests/typing-modules/d.ml
+++ /dev/null
@@ -1,2 +0,0 @@
-let x = 3
-module M = struct let y = 5 end
diff --git a/testsuite/tests/typing-modules/d.ml.reference b/testsuite/tests/typing-modules/d.ml.reference
deleted file mode 100644
index 06308c78..00000000
--- a/testsuite/tests/typing-modules/d.ml.reference
+++ /dev/null
@@ -1,5 +0,0 @@
-
-#     
-Characters 42-42:
-  Error: Syntax error
-# 
diff --git a/testsuite/tests/typing-modules/firstclass.ml b/testsuite/tests/typing-modules/firstclass.ml
index b778443a..8bf0e422 100644
--- a/testsuite/tests/typing-modules/firstclass.ml
+++ b/testsuite/tests/typing-modules/firstclass.ml
@@ -5,6 +5,12 @@ module type S' = sig type t = int type u = bool end;;
    are inferred *)
 let f (x : (module S with type t = 'a and type u = 'b)) = (x : (module S'));;
 let g x = (x : (module S with type t = 'a and type u = 'b) :> (module S'));;
+[%%expect{|
+module type S = sig type u type t end
+module type S' = sig type t = int type u = bool end
+val f : (module S with type t = int and type u = bool) -> (module S') = 
+val g : (module S with type t = int and type u = bool) -> (module S') = 
+|}];;
 
 (* with subtyping it is also ok to forget some types *)
 module type S2 = sig type u type t type w end;;
@@ -14,8 +20,24 @@ let f2 (x : (module S2 with type t = 'a and type u = 'b)) =
   (x : (module S'));; (* fail *)
 let k (x : (module S2 with type t = 'a)) =
   (x : (module S with type t = 'a));; (* fail *)
+[%%expect{|
+module type S2 = sig type u type t type w end
+val g2 : (module S2 with type t = int and type u = bool) -> (module S') =
+  
+val h : (module S2 with type t = 'a) -> (module S with type t = 'a) = 
+Line _, characters 3-4:
+Error: This expression has type
+         (module S2 with type t = int and type u = bool)
+       but an expression was expected of type (module S')
+|}];;
 
 (* but you cannot forget values (no physical coercions) *)
 module type S3 = sig type u type t val x : int end;;
 let g3 x =
   (x : (module S3 with type t = 'a and type u = 'b) :> (module S'));; (* fail *)
+[%%expect{|
+module type S3 = sig type u type t val x : int end
+Line _, characters 2-67:
+Error: Type (module S3 with type t = int and type u = bool)
+       is not a subtype of (module S')
+|}];;
diff --git a/testsuite/tests/typing-modules/firstclass.ml.reference b/testsuite/tests/typing-modules/firstclass.ml.reference
deleted file mode 100644
index db376005..00000000
--- a/testsuite/tests/typing-modules/firstclass.ml.reference
+++ /dev/null
@@ -1,27 +0,0 @@
-
-# module type S = sig type u type t end
-# module type S' = sig type t = int type u = bool end
-#   *   val f : (module S with type t = int and type u = bool) -> (module S') = 
-# val g : (module S with type t = int and type u = bool) -> (module S') = 
-#     module type S2 = sig type u type t type w end
-# val g2 : (module S2 with type t = int and type u = bool) -> (module S') =
-  
-# val h : (module S2 with type t = 'a) -> (module S with type t = 'a) = 
-#   Characters 63-64:
-    (x : (module S'));; (* fail *)
-     ^
-Error: This expression has type
-         (module S2 with type t = int and type u = bool)
-       but an expression was expected of type (module S')
-#   Characters 46-47:
-    (x : (module S with type t = 'a));; (* fail *)
-     ^
-Error: This expression has type (module S2 with type t = 'a)
-       but an expression was expected of type (module S with type t = 'a)
-#     module type S3 = sig type u type t val x : int end
-#   Characters 13-78:
-    (x : (module S3 with type t = 'a and type u = 'b) :> (module S'));; (* fail *)
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Type (module S3 with type t = int and type u = bool)
-       is not a subtype of (module S') 
-# 
diff --git a/testsuite/tests/typing-modules/generative.ml b/testsuite/tests/typing-modules/generative.ml
index dc5bf528..0fb23150 100644
--- a/testsuite/tests/typing-modules/generative.ml
+++ b/testsuite/tests/typing-modules/generative.ml
@@ -6,24 +6,70 @@ let v = (module struct let x = 3 end : S);;
 module F() = (val v);; (* ok *)
 module G (X : sig end) : S = F ();; (* ok *)
 module H (X : sig end) = (val v);; (* ok *)
+[%%expect{|
+module type S = sig val x : int end
+val v : (module S) = 
+module F : functor () -> S
+module G : functor (X : sig  end) -> S
+module H : functor (X : sig  end) -> S
+|}];;
 
 (* With type *)
 module type S = sig type t val x : t end;;
 let v = (module struct type t = int let x = 3 end : S);;
 module F() = (val v);; (* ok *)
+[%%expect{|
+module type S = sig type t val x : t end
+val v : (module S) = 
+module F : functor () -> S
+|}];;
 module G (X : sig end) : S = F ();; (* fail *)
+[%%expect{|
+Line _, characters 29-33:
+Error: This expression creates fresh types.
+       It is not allowed inside applicative functors.
+|}];;
 module H() = F();; (* ok *)
+[%%expect{|
+module H : functor () -> S
+|}];;
 
 (* Alias *)
 module U = struct end;;
 module M = F(struct end);; (* ok *)
+[%%expect{|
+module U : sig  end
+module M : S
+|}];;
 module M = F(U);; (* fail *)
+[%%expect{|
+Line _, characters 11-12:
+Error: This is a generative functor. It can only be applied to ()
+|}];;
 
 (* Cannot coerce between applicative and generative *)
 module F1 (X : sig end) = struct end;;
 module F2 : functor () -> sig end = F1;; (* fail *)
+[%%expect{|
+module F1 : functor (X : sig  end) -> sig  end
+Line _, characters 36-38:
+Error: Signature mismatch:
+       Modules do not match:
+         functor (X : sig  end) -> sig  end
+       is not included in
+         functor () -> sig  end
+|}];;
 module F3 () = struct end;;
 module F4 : functor (X : sig end) -> sig end = F3;; (* fail *)
+[%%expect{|
+module F3 : functor () -> sig  end
+Line _, characters 47-49:
+Error: Signature mismatch:
+       Modules do not match:
+         functor () -> sig  end
+       is not included in
+         functor (X : sig  end) -> sig  end
+|}];;
 
 (* tests for shortened functor notation () *)
 module X (X: sig end) (Y: sig end) = functor (Z: sig end) -> struct end;;
@@ -32,3 +78,9 @@ module Y = functor (X: sig end) (Y:sig end) -> functor (Z: sig end) ->
 module Z = functor (_: sig end) (_:sig end) (_: sig end) -> struct end;;
 module GZ : functor (X: sig end) () (Z: sig end) -> sig end
           = functor (X: sig end) () (Z: sig end) -> struct end;;
+[%%expect{|
+module X : functor (X : sig  end) (Y : sig  end) (Z : sig  end) -> sig  end
+module Y : functor (X : sig  end) (Y : sig  end) (Z : sig  end) -> sig  end
+module Z : sig  end -> sig  end -> sig  end -> sig  end
+module GZ : functor (X : sig  end) () (Z : sig  end) -> sig  end
+|}];;
diff --git a/testsuite/tests/typing-modules/generative.ml.reference b/testsuite/tests/typing-modules/generative.ml.reference
deleted file mode 100644
index 0f892d43..00000000
--- a/testsuite/tests/typing-modules/generative.ml.reference
+++ /dev/null
@@ -1,44 +0,0 @@
-
-#       module type S = sig val x : int end
-# val v : (module S) = 
-# module F : functor () -> S
-# module G : functor (X : sig  end) -> S
-# module H : functor (X : sig  end) -> S
-#     module type S = sig type t val x : t end
-# val v : (module S) = 
-# module F : functor () -> S
-# Characters 29-33:
-  module G (X : sig end) : S = F ();; (* fail *)
-                               ^^^^
-Error: This expression creates fresh types.
-       It is not allowed inside applicative functors.
-# module H : functor () -> S
-#     module U : sig  end
-# module M : S
-# Characters 11-12:
-  module M = F(U);; (* fail *)
-             ^
-Error: This is a generative functor. It can only be applied to ()
-#     module F1 : functor (X : sig  end) -> sig  end
-# Characters 36-38:
-  module F2 : functor () -> sig end = F1;; (* fail *)
-                                      ^^
-Error: Signature mismatch:
-       Modules do not match:
-         functor (X : sig  end) -> sig  end
-       is not included in
-         functor () -> sig  end
-# module F3 : functor () -> sig  end
-# Characters 47-49:
-  module F4 : functor (X : sig end) -> sig end = F3;; (* fail *)
-                                                 ^^
-Error: Signature mismatch:
-       Modules do not match:
-         functor () -> sig  end
-       is not included in
-         functor (X : sig  end) -> sig  end
-#     module X : functor (X : sig  end) (Y : sig  end) (Z : sig  end) -> sig  end
-#   module Y : functor (X : sig  end) (Y : sig  end) (Z : sig  end) -> sig  end
-# module Z : sig  end -> sig  end -> sig  end -> sig  end
-#   module GZ : functor (X : sig  end) () (Z : sig  end) -> sig  end
-# 
diff --git a/testsuite/tests/typing-modules/pr5911.ml b/testsuite/tests/typing-modules/pr5911.ml
index 1fa991f1..e6f73539 100644
--- a/testsuite/tests/typing-modules/pr5911.ml
+++ b/testsuite/tests/typing-modules/pr5911.ml
@@ -6,9 +6,19 @@ end;;
 module Good (X : S with type t := unit) = struct
  let () = X.x
 end;;
+[%%expect{|
+module type S = sig type t val x : t end
+module Good : functor (X : sig val x : unit end) -> sig  end
+|}];;
 
 module type T = sig module M : S end;;
 
-module Bad (X : T with type M.t := unit) = struct
+module Bad (X : T with type M.t = unit) = struct
  let () = X.M.x
 end;;
+[%%expect{|
+module type T = sig module M : S end
+module Bad :
+  functor (X : sig module M : sig type t = unit val x : t end end) ->
+    sig  end
+|}];;
diff --git a/testsuite/tests/typing-modules/pr5911.ml.reference b/testsuite/tests/typing-modules/pr5911.ml.reference
deleted file mode 100644
index e5357b84..00000000
--- a/testsuite/tests/typing-modules/pr5911.ml.reference
+++ /dev/null
@@ -1,9 +0,0 @@
-
-#       module type S = sig type t val x : t end
-#       module Good : functor (X : sig val x : unit end) -> sig  end
-#   module type T = sig module M : S end
-#       Characters 33-35:
-  module Bad (X : T with type M.t := unit) = struct
-                                  ^^
-Error: Syntax error
-# 
diff --git a/testsuite/tests/typing-modules/pr7207.ml b/testsuite/tests/typing-modules/pr7207.ml
index c0ac33d5..1968f87c 100644
--- a/testsuite/tests/typing-modules/pr7207.ml
+++ b/testsuite/tests/typing-modules/pr7207.ml
@@ -1,2 +1,7 @@
 module F (X : sig end) = struct type t = int end;;
 type t = F(Does_not_exist).t;;
+[%%expect{|
+module F : functor (X : sig  end) -> sig type t = int end
+Line _, characters 9-28:
+Error: Unbound module Does_not_exist
+|}];;
diff --git a/testsuite/tests/typing-modules/pr7207.ml.reference b/testsuite/tests/typing-modules/pr7207.ml.reference
deleted file mode 100644
index 4fe8e21e..00000000
--- a/testsuite/tests/typing-modules/pr7207.ml.reference
+++ /dev/null
@@ -1,7 +0,0 @@
-
-# module F : functor (X : sig  end) -> sig type t = int end
-# Characters 9-28:
-  type t = F(Does_not_exist).t;;
-           ^^^^^^^^^^^^^^^^^^^
-Error: Unbound module Does_not_exist
-# 
diff --git a/testsuite/tests/typing-modules/printing.ml b/testsuite/tests/typing-modules/printing.ml
index 77dd8c70..1f107b8f 100644
--- a/testsuite/tests/typing-modules/printing.ml
+++ b/testsuite/tests/typing-modules/printing.ml
@@ -7,8 +7,20 @@ module type S = sig
   end
 end;;
 module F (X : S) = X.M;;
+[%%expect{|
+module type S =
+  sig
+    class type c = object method m : int end
+    module M : sig class type d = c end
+  end
+module F : functor (X : S) -> sig class type d = X.c end
+|}];;
 
 (* PR#6648 *)
 
 module M = struct module N = struct let x = 1 end end;;
 #show_module M;;
+[%%expect{|
+module M : sig module N : sig val x : int end end
+module M : sig module N : sig ... end end
+|}];;
diff --git a/testsuite/tests/typing-modules/printing.ml.reference b/testsuite/tests/typing-modules/printing.ml.reference
deleted file mode 100644
index c5a9a773..00000000
--- a/testsuite/tests/typing-modules/printing.ml.reference
+++ /dev/null
@@ -1,10 +0,0 @@
-
-#               module type S =
-  sig
-    class type c = object method m : int end
-    module M : sig class type d = c end
-  end
-# module F : functor (X : S) -> sig class type d = X.c end
-#       module M : sig module N : sig val x : int end end
-# module M : sig module N : sig ... end end
-# 
diff --git a/testsuite/tests/typing-modules/recursive.ml b/testsuite/tests/typing-modules/recursive.ml
new file mode 100644
index 00000000..abf76e01
--- /dev/null
+++ b/testsuite/tests/typing-modules/recursive.ml
@@ -0,0 +1,7 @@
+(* PR#7324 *)
+
+module rec T : sig type t = T.t end = T;;
+[%%expect{|
+Line _, characters 15-35:
+Error: The type abbreviation T.t is cyclic
+|}]
diff --git a/testsuite/tests/typing-multifile/Makefile b/testsuite/tests/typing-multifile/Makefile
new file mode 100644
index 00000000..a9653bd9
--- /dev/null
+++ b/testsuite/tests/typing-multifile/Makefile
@@ -0,0 +1,32 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+GENERATED= a.ml b.ml c.ml
+
+default: pr7325
+
+pr7325:
+	@printf " ... testing pr7325:"
+	@echo "type _ t = T" > a.ml
+	@echo "type 'a t = 'a A.t" > b.ml
+	@echo 'external f : unit -> unit B.t = "%identity"' > c.ml
+	@$(OCAMLC) -c a.ml b.ml && rm a.cmi && $(OCAMLC) -c c.ml \
+	  && echo " => passed" || echo " => failed"
+
+clean: defaultclean
+	@rm -f $(GENERATED)
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-objects-bugs/pr7284_bad.ml b/testsuite/tests/typing-objects-bugs/pr7284_bad.ml
new file mode 100644
index 00000000..d6ba2ea5
--- /dev/null
+++ b/testsuite/tests/typing-objects-bugs/pr7284_bad.ml
@@ -0,0 +1,33 @@
+module type S = sig
+
+   type o1 = < bar : int; foo : int >
+   type o2 = private < foo : int; .. >
+
+   type v1 = T of o1
+   type v2 = T of o2
+
+ end
+
+ module M = struct
+
+   type o1 = < bar : int; foo : int >
+   type o2 = o1
+
+   type v1 = T of o1
+   type v2 = v1 = T of o2
+
+ end
+
+ module F(X : S) = struct
+
+   type 'a wit =
+   | V1 : string -> X.v1 wit
+   | V2 : int -> X.v2 wit
+
+   let f : X.v1 wit -> unit = function V1 s -> print_endline s
+
+ end [@@warning "+8"] [@@warnerror "+8"]
+
+ module N = F(M)
+
+ let () = N.f (N.V2 0)
diff --git a/testsuite/tests/typing-objects-bugs/pr7293_ok.ml b/testsuite/tests/typing-objects-bugs/pr7293_ok.ml
new file mode 100644
index 00000000..60528146
--- /dev/null
+++ b/testsuite/tests/typing-objects-bugs/pr7293_ok.ml
@@ -0,0 +1,11 @@
+type t = T : t
+type s = T
+
+class c = object (self : 'self)
+
+  method foo : s -> 'self = function
+    | T -> self#bar ()
+
+  method bar : unit -> 'self = fun () -> self
+
+end
diff --git a/testsuite/tests/typing-objects-bugs/yamagata021012_ok.ml b/testsuite/tests/typing-objects-bugs/yamagata021012_ok.ml
index fda0d123..0189310e 100644
--- a/testsuite/tests/typing-objects-bugs/yamagata021012_ok.ml
+++ b/testsuite/tests/typing-objects-bugs/yamagata021012_ok.ml
@@ -98,10 +98,10 @@ struct
 (* the internal representation is UCS4 with big endian*)
 (* The most significant digit appears first. *)
 let get_buf s i =
-  let n = Char.code s.[i] in
-  let n = (n lsl 8) lor (Char.code s.[i + 1]) in
-  let n = (n lsl 8) lor (Char.code s.[i + 2]) in
-  let n = (n lsl 8) lor (Char.code s.[i + 3]) in
+  let n = Bytes.get s i |> Char.code in
+  let n = (n lsl 8) lor (Bytes.get s (i + 1) |> Char.code) in
+  let n = (n lsl 8) lor (Bytes.get s (i + 2) |> Char.code) in
+  let n = (n lsl 8) lor (Bytes.get s (i + 3) |> Char.code) in
   UChar.chr_of_uint n
 
 let set_buf s i u =
@@ -130,16 +130,16 @@ class text_raw buf =
     inherit [cursor] ustorage_base
     val contents = buf
     method first = new cursor (self :> text_raw) 0
-    method len = (String.length contents) / 4
+    method len = (Bytes.length contents) / 4
     method get i = get_buf contents (4 * i)
     method nth i = new cursor (self :> text_raw) i
-    method copy = {< contents = String.copy contents >}
+    method copy = {< contents = Bytes.copy contents >}
     method sub pos len =
-      {< contents = String.sub contents (pos * 4) (len * 4) >}
+      {< contents = Bytes.sub contents (pos * 4) (len * 4) >}
     method concat (text : ustorage) =
-      let buf = String.create (String.length contents + 4 * text#len) in
-      String.blit contents 0 buf 0 (String.length contents);
-      init_buf buf (String.length contents) text;
+      let buf = Bytes.create (Bytes.length contents + 4 * text#len) in
+      Bytes.blit contents 0 buf 0 (Bytes.length contents);
+      init_buf buf (Bytes.length contents) text;
       {< contents = buf >}
   end
 and cursor text i =
@@ -161,7 +161,7 @@ class text init = text_raw (make_buf init)
 class string init = string_raw (make_buf init)
 
 let of_string s =
-  let buf = String.make (4 * String.length s) '\000' in
+  let buf = Bytes.make (4 * String.length s) '\000' in
   for i = 0 to String.length s - 1 do
     buf.[4 * i] <- s.[i]
   done;
diff --git a/testsuite/tests/typing-objects/Tests.ml b/testsuite/tests/typing-objects/Tests.ml
index c52fe909..b646ade3 100644
--- a/testsuite/tests/typing-objects/Tests.ml
+++ b/testsuite/tests/typing-objects/Tests.ml
@@ -88,7 +88,7 @@ and 'a d = ;;
 type 'a c = 
 and 'a d = ;;
 type 'a u = < x : 'a>
-and 'a t = 'a t u;;
+and 'a t = 'a t u;; (* fails since 4.04 *)
 type 'a u = 'a
 and 'a t = 'a t u;;
 type 'a u = 'a;;
diff --git a/testsuite/tests/typing-objects/Tests.ml.principal.reference b/testsuite/tests/typing-objects/Tests.ml.principal.reference
index d39a70dc..c4c59562 100644
--- a/testsuite/tests/typing-objects/Tests.ml.principal.reference
+++ b/testsuite/tests/typing-objects/Tests.ml.principal.reference
@@ -67,8 +67,11 @@ Error: In the definition of d, type int c should be 'a c
 and 'a d = < f : 'a c >
 #   type 'a c = < f : 'a c >
 and 'a d = < f : int c >
-#   type 'a u = < x : 'a >
-and 'a t = 'a t u
+#   Characters 22-39:
+  and 'a t = 'a t u;; (* fails since 4.04 *)
+  ^^^^^^^^^^^^^^^^^
+Error: The definition of t contains a cycle:
+       'a t u
 #   Characters 15-32:
   and 'a t = 'a t u;;
   ^^^^^^^^^^^^^^^^^
diff --git a/testsuite/tests/typing-objects/Tests.ml.reference b/testsuite/tests/typing-objects/Tests.ml.reference
index d39a70dc..c4c59562 100644
--- a/testsuite/tests/typing-objects/Tests.ml.reference
+++ b/testsuite/tests/typing-objects/Tests.ml.reference
@@ -67,8 +67,11 @@ Error: In the definition of d, type int c should be 'a c
 and 'a d = < f : 'a c >
 #   type 'a c = < f : 'a c >
 and 'a d = < f : int c >
-#   type 'a u = < x : 'a >
-and 'a t = 'a t u
+#   Characters 22-39:
+  and 'a t = 'a t u;; (* fails since 4.04 *)
+  ^^^^^^^^^^^^^^^^^
+Error: The definition of t contains a cycle:
+       'a t u
 #   Characters 15-32:
   and 'a t = 'a t u;;
   ^^^^^^^^^^^^^^^^^
diff --git a/testsuite/tests/typing-pattern_open/Makefile b/testsuite/tests/typing-pattern_open/Makefile
new file mode 100644
index 00000000..9625a3fb
--- /dev/null
+++ b/testsuite/tests/typing-pattern_open/Makefile
@@ -0,0 +1,3 @@
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-pattern_open/pattern_open.ml b/testsuite/tests/typing-pattern_open/pattern_open.ml
new file mode 100644
index 00000000..07390ad5
--- /dev/null
+++ b/testsuite/tests/typing-pattern_open/pattern_open.ml
@@ -0,0 +1,147 @@
+let pp fmt = Printf.printf fmt
+
+type 'a box = B of 'a
+(* Basic tests *)
+module M = struct
+  type c = C
+  type t = {x : c box }
+end
+;;
+module N = struct
+  type d = D
+  let d = D
+  type t = {x: d box}
+end
+open N
+;;
+let f M.{ x=B C } y  = M.C,y
+;;
+let g M.(x) M.(w) = x * w
+;;
+let g = function
+  | M.[] -> []
+  | M.[C] -> M.[C]
+  | _ -> []
+;;
+let h = function
+  | M.[||] -> None
+  | M.[| C |] -> Some M.C
+  | _ -> None
+;;
+let f2 = function
+  | M.( B (B C) ) -> M.C
+;;
+
+;;
+(* () constructor *)
+let M.() = ()
+;;
+(* Pattern open separation*)
+module L = struct
+  type _ c = C : unit c
+  type t = { t : unit c }
+  type r = { r : unit c }
+  let x ()= pp "Wrong value L.x\n"
+end
+;;
+module K = struct
+  type _ c = C : unit c
+  type t = { t : unit c }
+  type r = { r : unit c }
+  let x ()= pp "Right value K.x\n"
+end
+;;
+let () =
+  let test =
+  let open K in
+  function
+  | L.{t}, ({r=C} : K.r)  -> x ()
+  in
+  test (L.{t=C}, K.{r=C})
+;;
+module Exterior = struct
+module Gadt = struct
+module Boolean = struct
+  type t = { b : bool }
+  type wrong = false | true
+  let print () = pp "Wrong function: Exterior.Gadt.Boolean.print\n"
+end
+
+type _ t =
+  | Bool : Boolean.t -> bool t
+  | Int : int -> int t
+  | Eq : 'a t * 'a t -> bool t
+
+let print () = pp "Wrong function: Exterior.Gadt.print\n"
+end
+let print () = pp "Wrong function: Exterior.print\n"
+end
+;;
+let rec eval: type t. t Exterior.Gadt.t -> t = function
+  | Exterior.( Gadt.( Eq (a,b) ) ) -> (eval a) = (eval b)
+  | Exterior.( Gadt.( Bool Boolean.{b} ) ) -> b
+  | Exterior.Gadt.( Int n ) -> n
+let () =
+  let print () = pp "Right function print\n" in
+  let choose (type a):a Exterior.Gadt.t * a Exterior.Gadt.t -> a -> a =
+  fun (a,b) c ->
+  match a, b, c with
+  | Exterior.( Gadt.( Bool Boolean.{b} ), Gadt.Bool _ , _ ) -> print(); true
+  | Exterior.(Gadt.Bool Gadt.Boolean.{b}), _ , true -> print(); true
+  | Exterior.(Gadt.Bool Gadt.Boolean.{b}), _ , false -> print(); b
+  | Exterior.Gadt.( Int n, Int k, 0 ) -> print(); 0
+  | Exterior.( Gadt.(Int n, Gadt.Int k, l) ) -> print(); k+n+l
+  | Exterior.Gadt.( Eq (a,b) ), _,  true -> print(); true
+  | Exterior.(Gadt.( Eq (a,b), _ ,  false )) -> print(); eval a = eval b in
+  let _ =
+    choose Exterior.Gadt.(Bool Boolean.{b=true}, Bool Boolean.{b=false}) false
+  in
+  print ()
+;;
+(* existential type *)
+module Existential = struct
+type printable = E : 'a * ('a -> unit) -> printable
+end
+
+let rec print: Existential.printable -> unit  = function
+  | Existential.( E(x, print) ) -> print x
+;;
+(* Test that constructors and variables introduced in scope inside
+M.(..) are not propagated outside of M.(..) *)
+module S = struct
+type 'a t = Sep : unit t
+type ex = Ex: 'a * 'a -> ex
+let s = Sep
+end
+;;
+let test_separation = function
+  | S.(Sep), (S.(Sep,Sep), Sep) -> ()
+;;
+let test_separation_2 = function
+  | S.(Ex(a,b)), Ex(c,d) -> ()
+;;
+let test_separation_3 = function
+  | S.(Sep) -> s
+;;
+
+(* Testing interaction of local open in pattern and backtracking *)
+module PR6437 = struct
+  module Ctx = struct
+  type ('a, 'b) t =
+    | Nil : (unit, unit) t
+    | Cons : ('a, 'b) t -> ('a * unit, 'b * unit) t
+  end
+
+  module Var = struct
+  type 'a t =
+    | O : ('a * unit) t
+    | S : 'a t -> ('a * unit) t
+  end
+end
+
+let rec f : type g1 g2. (g1, g2) PR6437.Ctx.t * g1 PR6437.Var.t
+  -> g2 PR6437.Var.t = function
+    | PR6437.( Ctx.(Cons g), Var.(O) ) -> PR6437.Var.O
+    | PR6437.( Ctx.(Cons g), Var.(S n) ) -> PR6437.Var.S (f (g, n))
+    | _ -> .
+;;
diff --git a/testsuite/tests/typing-pattern_open/pattern_open.ml.reference b/testsuite/tests/typing-pattern_open/pattern_open.ml.reference
new file mode 100644
index 00000000..f97b7374
--- /dev/null
+++ b/testsuite/tests/typing-pattern_open/pattern_open.ml.reference
@@ -0,0 +1,81 @@
+
+#                 val pp : ('a, out_channel, unit) format -> 'a = 
+type 'a box = B of 'a
+module M : sig type c = C type t = { x : c box; } end
+#             module N : sig type d = D val d : d type t = { x : d box; } end
+#   val f : M.t -> 'a -> M.c * 'a = 
+#   val g : int -> int -> int = 
+#         val g : M.c list -> M.c list = 
+#         val h : M.c array -> M.c option = 
+#     val f2 : M.c box box -> M.c = 
+#   #     #               module L :
+  sig
+    type _ c = C : unit c
+    type t = { t : unit c; }
+    type r = { r : unit c; }
+    val x : unit -> unit
+  end
+#             module K :
+  sig
+    type _ c = C : unit c
+    type t = { t : unit c; }
+    type r = { r : unit c; }
+    val x : unit -> unit
+  end
+#               Right value K.x
+#                                   module Exterior :
+  sig
+    module Gadt :
+      sig
+        module Boolean :
+          sig
+            type t = { b : bool; }
+            type wrong = false | true
+            val print : unit -> unit
+          end
+        type _ t =
+            Bool : Boolean.t -> bool t
+          | Int : int -> int t
+          | Eq : 'a t * 'a t -> bool t
+        val print : unit -> unit
+      end
+    val print : unit -> unit
+  end
+#                                         Right function print
+Right function print
+val eval : 't Exterior.Gadt.t -> 't = 
+#               module Existential :
+  sig type printable = E : 'a * ('a -> unit) -> printable end
+val print : Existential.printable -> unit = 
+# *             module S :
+  sig
+    type 'a t = Sep : unit t
+    type ex = Ex : 'a * 'a -> ex
+    val s : unit t
+  end
+#     Characters 58-61:
+    | S.(Sep), (S.(Sep,Sep), Sep) -> ()
+                             ^^^
+Error: Unbound constructor Sep
+#     Characters 50-52:
+    | S.(Ex(a,b)), Ex(c,d) -> ()
+                   ^^
+Error: Unbound constructor Ex
+#     Characters 48-49:
+    | S.(Sep) -> s
+                 ^
+Error: Unbound value s
+#                                           module PR6437 :
+  sig
+    module Ctx :
+      sig
+        type ('a, 'b) t =
+            Nil : (unit, unit) t
+          | Cons : ('a, 'b) t -> ('a * unit, 'b * unit) t
+      end
+    module Var :
+      sig type 'a t = O : ('a * unit) t | S : 'a t -> ('a * unit) t end
+  end
+val f : ('g1, 'g2) PR6437.Ctx.t * 'g1 PR6437.Var.t -> 'g2 PR6437.Var.t =
+  
+# 
diff --git a/testsuite/tests/typing-poly/Makefile b/testsuite/tests/typing-poly/Makefile
index 7fc00661..0b15e777 100644
--- a/testsuite/tests/typing-poly/Makefile
+++ b/testsuite/tests/typing-poly/Makefile
@@ -14,5 +14,5 @@
 #**************************************************************************
 
 BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.expect
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-poly/poly.ml b/testsuite/tests/typing-poly/poly.ml
index 1ddc6d6c..4b3d9e5d 100644
--- a/testsuite/tests/typing-poly/poly.ml
+++ b/testsuite/tests/typing-poly/poly.ml
@@ -10,6 +10,12 @@ type 'a t = { t : 'a };;
 type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b };;
 let f l = { fold = List.fold_left l };;
 (f [1;2;3]).fold ~f:(+) ~init:0;;
+[%%expect {|
+type 'a t = { t : 'a; }
+type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b; }
+val f : 'a list -> 'a fold = 
+- : int = 6
+|}];;
 
 class ['b] ilist l = object
   val l = l
@@ -18,11 +24,29 @@ class ['b] ilist l = object
     List.fold_left l
 end
 ;;
+[%%expect {|
+class ['b] ilist :
+  'b list ->
+  object ('c)
+    val l : 'b list
+    method add : 'b -> 'c
+    method fold : f:('a -> 'b -> 'a) -> init:'a -> 'a
+  end
+|}];;
+
 class virtual ['a] vlist = object (_ : 'self)
   method virtual add : 'a -> 'self
   method virtual fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b
 end
 ;;
+[%%expect {|
+class virtual ['a] vlist :
+  object ('c)
+    method virtual add : 'a -> 'c
+    method virtual fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
+  end
+|}];;
+
 class ilist2 l = object
   inherit [int] vlist
   val l = l
@@ -30,6 +54,16 @@ class ilist2 l = object
   method fold = List.fold_left l
 end
 ;;
+[%%expect {|
+class ilist2 :
+  int list ->
+  object ('a)
+    val l : int list
+    method add : int -> 'a
+    method fold : f:('b -> int -> 'b) -> init:'b -> 'b
+  end
+|}];;
+
 let ilist2 l = object
   inherit [_] vlist
   val l = l
@@ -37,6 +71,10 @@ let ilist2 l = object
   method fold = List.fold_left l
 end
 ;;
+[%%expect {|
+val ilist2 : 'a list -> 'a vlist = 
+|}];;
+
 class ['a] ilist3 l = object
   inherit ['a] vlist
   val l = l
@@ -44,6 +82,16 @@ class ['a] ilist3 l = object
   method fold = List.fold_left l
 end
 ;;
+[%%expect {|
+class ['a] ilist3 :
+  'a list ->
+  object ('c)
+    val l : 'a list
+    method add : 'a -> 'c
+    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
+  end
+|}];;
+
 class ['a] ilist4 (l : 'a list) = object
   val l = l
   method virtual add : _
@@ -52,6 +100,16 @@ class ['a] ilist4 (l : 'a list) = object
   method fold = List.fold_left l
 end
 ;;
+[%%expect {|
+class ['a] ilist4 :
+  'a list ->
+  object ('c)
+    val l : 'a list
+    method add : 'a -> 'c
+    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
+  end
+|}];;
+
 class ['a] ilist5 (l : 'a list) = object (self)
   val l = l
   method add x = {< l = x :: l >}
@@ -61,6 +119,17 @@ class ['a] ilist5 (l : 'a list) = object (self)
   method fold = List.fold_left l
 end
 ;;
+[%%expect {|
+class ['a] ilist5 :
+  'a list ->
+  object ('c)
+    val l : 'a list
+    method add : 'a -> 'c
+    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
+    method fold2 : f:('b -> 'a -> 'b) -> init:'b -> 'b
+  end
+|}];;
+
 class ['a] ilist6 l = object (self)
   inherit ['a] vlist
   val l = l
@@ -70,15 +139,36 @@ class ['a] ilist6 l = object (self)
   method fold = List.fold_left l
 end
 ;;
+[%%expect {|
+class ['a] ilist6 :
+  'a list ->
+  object ('c)
+    val l : 'a list
+    method add : 'a -> 'c
+    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
+    method fold2 : f:('b -> 'a -> 'b) -> init:'b -> 'b
+  end
+|}];;
+
 class virtual ['a] olist = object
   method virtual fold : 'c. f:('a -> 'c -> 'c) -> init:'c -> 'c
 end
 ;;
+[%%expect {|
+class virtual ['a] olist :
+  object method virtual fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end
+|}];;
+
 class ['a] onil = object
   inherit ['a] olist
   method fold ~f ~init = init
 end
 ;;
+[%%expect {|
+class ['a] onil :
+  object method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end
+|}];;
+
 class ['a] ocons ~hd ~tl = object (_ : 'b)
   inherit ['a] olist
   val hd : 'a = hd
@@ -86,6 +176,17 @@ class ['a] ocons ~hd ~tl = object (_ : 'b)
   method fold ~f ~init = f hd (tl#fold ~f ~init)
 end
 ;;
+[%%expect {|
+class ['a] ocons :
+  hd:'a ->
+  tl:'a olist ->
+  object
+    val hd : 'a
+    val tl : 'a olist
+    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
+  end
+|}];;
+
 class ['a] ostream ~hd ~tl = object (_ : 'b)
   inherit ['a] olist
   val hd : 'a = hd
@@ -94,6 +195,18 @@ class ['a] ostream ~hd ~tl = object (_ : 'b)
   method empty = false
 end
 ;;
+[%%expect {|
+class ['a] ostream :
+  hd:'a ->
+  tl:'a ostream ->
+  object
+    val hd : 'a
+    val tl : < empty : bool; fold : 'c. f:('a -> 'c -> 'c) -> init:'c -> 'c >
+    method empty : bool
+    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
+  end
+|}];;
+
 class ['a] ostream1 ~hd ~tl = object (self : 'b)
   inherit ['a] olist
   val hd = hd
@@ -103,33 +216,78 @@ class ['a] ostream1 ~hd ~tl = object (self : 'b)
   method fold ~f ~init =
     self#tl#fold ~f ~init:(f self#hd init)
 end
-;;
+[%%expect {|
+class ['a] ostream1 :
+  hd:'a ->
+  tl:'b ->
+  object ('b)
+    val hd : 'a
+    val tl : 'b
+    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
+    method hd : 'a
+    method tl : 'b
+  end
+|}, Principal{|
+Line _, characters 4-16:
+Warning 18: this use of a polymorphic method is not principal.
+class ['a] ostream1 :
+  hd:'a ->
+  tl:'b ->
+  object ('b)
+    val hd : 'a
+    val tl : 'b
+    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
+    method hd : 'a
+    method tl : 'b
+  end
+|}];;
 
 class vari = object
   method virtual m : 'a. ([< `A|`B|`C] as 'a) -> int
   method m = function `A -> 1 | `B|`C  -> 0
 end
 ;;
+[%%expect {|
+class vari : object method m : [< `A | `B | `C ] -> int end
+|}];;
+
 class vari = object
   method m : 'a. ([< `A|`B|`C] as 'a) -> int = function `A -> 1 | `B|`C -> 0
 end
 ;;
+[%%expect {|
+class vari : object method m : [< `A | `B | `C ] -> int end
+|}];;
+
 module V =
   struct
     type v = [`A | `B | `C]
     let m : [< v] -> int = function `A -> 1 | #v -> 0
   end
 ;;
+[%%expect {|
+module V : sig type v = [ `A | `B | `C ] val m : [< v ] -> int end
+|}];;
+
 class varj = object
   method virtual m : 'a. ([< V.v] as 'a) -> int
   method m = V.m
 end
 ;;
+[%%expect {|
+class varj : object method m : [< V.v ] -> int end
+|}];;
+
 
 module type T = sig
   class vari : object method m : 'a. ([< `A | `B | `C] as 'a) -> int end
 end
 ;;
+[%%expect {|
+module type T =
+  sig class vari : object method m : [< `A | `B | `C ] -> int end end
+|}];;
+
 module M0 = struct
   class vari = object
     method virtual m : 'a. ([< `A|`B|`C] as 'a) -> int
@@ -137,10 +295,27 @@ module M0 = struct
   end
 end
 ;;
+[%%expect {|
+module M0 :
+  sig class vari : object method m : [< `A | `B | `C ] -> int end end
+|}];;
+
 module M : T = M0
 ;;
+[%%expect {|
+module M : T
+|}];;
+
 let v = new M.vari;;
+[%%expect {|
+val v : M.vari = 
+|}];;
+
 v#m `A;;
+[%%expect {|
+- : int = 1
+|}];;
+
 
 class point ~x ~y = object
   val x : int = x
@@ -149,12 +324,33 @@ class point ~x ~y = object
   method y = y
 end
 ;;
+[%%expect {|
+class point :
+  x:int ->
+  y:int -> object val x : int val y : int method x : int method y : int end
+|}];;
+
 class color_point ~x ~y ~color = object
   inherit point ~x ~y
   val color : string = color
   method color = color
 end
 ;;
+[%%expect {|
+class color_point :
+  x:int ->
+  y:int ->
+  color:string ->
+  object
+    val color : string
+    val x : int
+    val y : int
+    method color : string
+    method x : int
+    method y : int
+  end
+|}];;
+
 class circle (p : #point) ~r = object
   val p = (p :> point)
   val r = r
@@ -165,6 +361,13 @@ class circle (p : #point) ~r = object
     if d < 0. then 0. else d
 end
 ;;
+[%%expect {|
+class circle :
+  #point ->
+  r:int ->
+  object val p : point val r : int method distance : #point -> float end
+|}];;
+
 let p0 = new point ~x:3 ~y:5
 let p1 = new point ~x:10 ~y:13
 let cp = new color_point ~x:12 ~y:(-5) ~color:"green"
@@ -175,21 +378,43 @@ let f (x : < m : 'a. 'a -> 'a >) = (x : < m : 'b. 'b -> 'b >)
 ;;
 let f (x : < m : 'a. 'a -> 'a list >) = (x : < m : 'b. 'b -> 'c >)
 ;;
+[%%expect {|
+val p0 : point = 
+val p1 : point = 
+val cp : color_point = 
+val c : circle = 
+val d : float = 11.
+val f : < m : 'a. 'a -> 'a > -> < m : 'b. 'b -> 'b > = 
+Line _, characters 41-42:
+Error: This expression has type < m : 'b. 'b -> 'b list >
+       but an expression was expected of type < m : 'b. 'b -> 'c >
+       The universal variable 'b would escape its scope
+|}];;
 
 class id = object
   method virtual id : 'a. 'a -> 'a
   method id x = x
 end
 ;;
+[%%expect {|
+class id : object method id : 'a -> 'a end
+|}];;
 
 class type id_spec = object
   method id : 'a -> 'a
 end
 ;;
+[%%expect {|
+class type id_spec = object method id : 'a -> 'a end
+|}];;
+
 class id_impl = object (_ : #id_spec)
   method id x = x
 end
 ;;
+[%%expect {|
+class id_impl : object method id : 'a -> 'a end
+|}];;
 
 class a = object
   method m = (new b : id_spec)#id true
@@ -198,23 +423,43 @@ and b = object (_ : #id_spec)
   method id x = x
 end
 ;;
+[%%expect {|
+class a : object method m : bool end
+and b : object method id : 'a -> 'a end
+|}];;
+
 
 class ['a] id1 = object
   method virtual id : 'b. 'b -> 'a
   method id x = x
 end
 ;;
+[%%expect {|
+Line _, characters 12-17:
+Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
+|}];;
+
 class id2 (x : 'a) = object
   method virtual id : 'b. 'b -> 'a
   method id x = x
 end
 ;;
+[%%expect {|
+Line _, characters 12-17:
+Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
+|}];;
+
 class id3 x = object
   val x = x
   method virtual id : 'a. 'a -> 'a
   method id _ = x
 end
 ;;
+[%%expect {|
+Line _, characters 12-17:
+Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a
+|}];;
+
 class id4 () = object
   val mutable r = None
   method virtual id : 'a. 'a -> 'a
@@ -224,11 +469,20 @@ class id4 () = object
     | Some y -> y
 end
 ;;
+[%%expect {|
+Line _, characters 12-79:
+Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a
+|}];;
+
 class c = object
   method virtual m : 'a 'b. 'a -> 'b -> 'a
   method m x y = x
 end
 ;;
+[%%expect {|
+class c : object method m : 'a -> 'b -> 'a end
+|}];;
+
 
 let f1 (f : id) = f#id 1, f#id true
 ;;
@@ -238,12 +492,23 @@ let f3 f = f#id 1, f#id true
 ;;
 let f4 f = ignore(f : id); f#id 1, f#id true
 ;;
+[%%expect {|
+val f1 : id -> int * bool = 
+val f2 : id -> int * bool = 
+Line _, characters 24-28:
+Error: This expression has type bool but an expression was expected of type
+         int
+|}];;
 
 class c = object
   method virtual m : 'a. (#id as 'a) -> int * bool
   method m (f : #id) = f#id 1, f#id true
 end
 ;;
+[%%expect {|
+class c : object method m : #id -> int * bool end
+|}];;
+
 
 class id2 = object (_ : 'b)
   method virtual id : 'a. 'a -> 'a
@@ -255,11 +520,21 @@ let app = new c #m (new id2)
 ;;
 type 'a foo = 'a foo list
 ;;
+[%%expect {|
+class id2 : object method id : 'a -> 'a method mono : int -> int end
+val app : int * bool = (1, true)
+Line _, characters 0-25:
+Error: The type abbreviation foo is cyclic
+|}];;
 
 class ['a] bar (x : 'a) = object end
 ;;
 type 'a foo = 'a foo bar
 ;;
+[%%expect {|
+class ['a] bar : 'a -> object  end
+type 'a foo = 'a foo bar
+|}];;
 
 fun x -> (x : < m : 'a. 'a * 'b > as 'b)#m;;
 fun x -> (x : < m : 'a. 'b * 'a list> as 'b)#m;;
@@ -268,17 +543,63 @@ fun (x : < p : 'a. < m : 'a ; n : 'b ; .. > as 'a > as 'b) -> x#p;;
 fun (x :  as 'c> as 'd) -> x#m;;
 (* printer is wrong on the next (no official syntax) *)
 fun (x :  >) -> x#m;;
+[%%expect {|
+- : (< m : 'a. 'a * 'b > as 'b) -> 'c * 'b = 
+- : (< m : 'a. 'b * 'a list > as 'b) -> 'b * 'c list = 
+val f :
+  (< m : 'b. 'a * (< n : 'b; .. > as 'b) > as 'a) ->
+  'a * (< n : 'c; .. > as 'c) = 
+- : (< p : 'b. < m : 'b; n : 'a; .. > as 'b > as 'a) ->
+    (< m : 'c; n : 'a; .. > as 'c)
+= 
+- : (< m : 'a. 'a * < p : 'b. 'b * 'd * 'c > as 'd > as 'c) ->
+    ('f * < p : 'b. 'b * 'e * 'c > as 'e)
+= 
+- : < m : 'a. < p : 'a; .. > as 'b > -> 'b = 
+|}, Principal{|
+- : (< m : 'a. 'a * 'b > as 'b) -> 'c * (< m : 'a. 'a * 'd > as 'd) = 
+- : (< m : 'a. 'b * 'a list > as 'b) ->
+    (< m : 'a. 'c * 'a list > as 'c) * 'd list
+= 
+val f :
+  (< m : 'b. 'a * (< n : 'b; .. > as 'b) > as 'a) ->
+  (< m : 'd. 'c * (< n : 'd; .. > as 'd) > as 'c) * (< n : 'e; .. > as 'e) =
+  
+- : (< p : 'b. < m : 'b; n : 'a; .. > as 'b > as 'a) ->
+    (< m : 'c; n : < p : 'e. < m : 'e; n : 'd; .. > as 'e > as 'd; .. > as 'c)
+= 
+- : (< m : 'a. 'a * < p : 'b. 'b * 'd * 'c > as 'd > as 'c) ->
+    ('f *
+     < p : 'b.
+             'b * 'e *
+             (< m : 'a. 'a * < p : 'b0. 'b0 * 'h * 'g > as 'h > as 'g) >
+     as 'e)
+= 
+- : < m : 'a. < p : 'a; .. > as 'b > -> 'b = 
+|}];;
 
 type sum = T of < id: 'a. 'a -> 'a > ;;
 fun (T x) -> x#id;;
+[%%expect {|
+type sum = T of < id : 'a. 'a -> 'a >
+- : sum -> 'a -> 'a = 
+|}];;
 
 type record = { r: < id: 'a. 'a -> 'a > } ;;
 fun x -> x.r#id;;
 fun {r=x} -> x#id;;
+[%%expect {|
+type record = { r : < id : 'a. 'a -> 'a >; }
+- : record -> 'a -> 'a = 
+- : record -> 'a -> 'a = 
+|}];;
 
 class myself = object (self)
   method self : 'a. 'a -> 'b = fun _ -> self
 end;;
+[%%expect {|
+class myself : object ('b) method self : 'a -> 'b end
+|}];;
 
 class number = object (self : 'self)
   val num = 0
@@ -291,6 +612,16 @@ class number = object (self : 'self)
       if num = 0 then zero () else prev {< num = num - 1 >}
 end
 ;;
+[%%expect {|
+class number :
+  object ('b)
+    val num : int
+    method num : int
+    method prev : 'b
+    method succ : 'b
+    method switch : zero:(unit -> 'a) -> prev:('b -> 'a) -> 'a
+  end
+|}];;
 
 let id x = x
 ;;
@@ -325,20 +656,57 @@ let count (l : 'a #olist) = l#fold ~f:(fun _ acc -> acc+1) ~init:0
 let append (l : 'a #olist) (l' : 'b #olist) =
   l#fold ~init:l' ~f:(fun x acc -> acc#cons x)
 ;;
+[%%expect {|
+val id : 'a -> 'a = 
+class c : object method id : 'a -> 'a end
+class c' : object method id : 'a -> 'a end
+class d :
+  object
+    val mutable count : int
+    method count : int
+    method id : 'a -> 'a
+    method old : 'a -> 'a
+  end
+class ['a] olist :
+  'a list ->
+  object ('c)
+    val l : 'a list
+    method cons : 'a -> 'c
+    method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b
+  end
+val sum : int #olist -> int = 
+val count : 'a #olist -> int = 
+val append : 'a #olist -> ('a #olist as 'b) -> 'b = 
+|}];;
 
 type 'a t = unit
 ;;
 class o = object method x : 'a. ([> `A] as 'a) t -> unit = fun _ -> () end
 ;;
+[%%expect {|
+type 'a t = unit
+class o : object method x : [> `A ] t -> unit end
+|}];;
 
 class c = object method m = new d () end and d ?(x=0) () = object end;;
 class d ?(x=0) () = object end and c = object method m = new d () end;;
+[%%expect {|
+class c : object method m : d end
+and d : ?x:int -> unit -> object  end
+class d : ?x:int -> unit -> object  end
+and c : object method m : d end
+|}];;
 
 class type numeral = object method fold : ('a -> 'a) -> 'a -> 'a end
 class zero = object (_ : #numeral) method fold f x = x end
 class next (n : #numeral) =
   object (_ : #numeral) method fold f x = n#fold f (f x) end
 ;;
+[%%expect {|
+class type numeral = object method fold : ('a -> 'a) -> 'a -> 'a end
+class zero : object method fold : ('a -> 'a) -> 'a -> 'a end
+class next : #numeral -> object method fold : ('a -> 'a) -> 'a -> 'a end
+|}];;
 
 class type node_type =  object
   method as_variant : [> `Node of node_type]
@@ -350,17 +718,37 @@ end;;
 class node = object (self : #node_type)
   method as_variant = `Node (self :> node_type)
 end;;
+[%%expect {|
+class type node_type = object method as_variant : [> `Node of node_type ] end
+class node : node_type
+class node : object method as_variant : [> `Node of node_type ] end
+|}];;
 
 type bad = {bad : 'a. 'a option ref};;
 let bad = {bad = ref None};;
 type bad2 = {mutable bad2 : 'a. 'a option ref option};;
 let bad2 = {bad2 = None};;
 bad2.bad2 <- Some (ref None);;
+[%%expect {|
+type bad = { bad : 'a. 'a option ref; }
+Line _, characters 17-25:
+Error: This field value has type 'b option ref which is less general than
+         'a. 'a option ref
+|}];;
 
 (* Type variable scope *)
 
 let f (x:  as 'b>) (y : 'b) = ();;
 let f (x:  as 'b)>) (y : 'b) = ();;
+[%%expect {|
+val f : < m : 'a. < p : 'a * 'c > as 'c > -> 'b -> unit = 
+val f : < m : 'a. 'a * (< p : int * 'b > as 'b) > -> 'b -> unit = 
+|}, Principal{|
+val f : < m : 'a. < p : 'a * 'c > as 'c > -> 'b -> unit = 
+val f :
+  < m : 'a. 'a * (< p : int * 'b > as 'b) > ->
+  (< p : int * 'c > as 'c) -> unit = 
+|}];;
 
 (* PR#1374 *)
 
@@ -377,60 +765,130 @@ end;;
 class c = object (self)
   method m :  'a. ([> 'a t] as 'a) -> 'a = fun x -> self#m x
 end;;
+[%%expect {|
+type 'a t = [ `A of 'a ]
+class c : object method m : ([> 'a t ] as 'a) -> unit end
+class c : object method m : ([> 'a t ] as 'a) -> unit end
+class c : object method m : ([> 'a t ] as 'a) -> 'a end
+|}];;
 
 (* use before instancing *)
 class c = object method m : 'a. 'a option -> ([> `A] as 'a) = fun x -> `A end;;
+[%%expect {|
+class c : object method m : ([> `A ] as 'a) option -> 'a end
+|}];;
 
 (* various old bugs *)
 class virtual ['a] visitor =
 object method virtual caseNil : 'a end
 and virtual int_list =
 object method virtual visit : 'a.('a visitor -> 'a) end;;
+[%%expect {|
+Line _, characters 30-51:
+Error: The universal type variable 'a cannot be generalized:
+       it escapes its scope.
+|}];;
 
 type ('a,'b) list_visitor = < caseNil : 'a; caseCons : 'b -> 'b list -> 'a >
 type 'b alist = < visit : 'a. ('a,'b) list_visitor -> 'a >
+[%%expect {|
+type ('a, 'b) list_visitor = < caseCons : 'b -> 'b list -> 'a; caseNil : 'a >
+type 'b alist = < visit : 'a. ('a, 'b) list_visitor -> 'a >
+|}];;
 
 (* PR#1607 *)
 class type ct = object ('s)
   method fold : ('b -> 's -> 'b) -> 'b -> 'b
 end
 type t = {f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b};;
+[%%expect {|
+class type ct = object ('a) method fold : ('b -> 'a -> 'b) -> 'b -> 'b end
+type t = { f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b; }
+|}];;
 
 (* PR#1663 *)
 type t = u and u = t;;
+[%%expect {|
+Line _, characters 0-10:
+Error: The definition of t contains a cycle:
+       u
+|}];;
 
 (* PR#1731 *)
 class ['t] a = object constraint 't = [> `A of 't a] end
 type t = [ `A of t a ];;
+[%%expect {|
+class ['a] a : object constraint 'a = [> `A of 'a a ] end
+type t = [ `A of t a ]
+|}];;
 
 (* Wrong in 3.06 *)
 type ('a,'b) t constraint 'a = 'b and ('a,'b) u = ('a,'b) t;;
+[%%expect {|
+Line _, characters 50-59:
+Error: Constraints are not satisfied in this type.
+       Type ('a, 'b) t should be an instance of ('c, 'c) t
+|}];;
 
 (* Full polymorphism if we do not expand *)
 type 'a t = 'a and u = int t;;
+[%%expect {|
+type 'a t = 'a
+and u = int t
+|}];;
 
 (* Loose polymorphism if we expand *)
 type 'a t constraint 'a = int;;
 type 'a u = 'a and 'a v = 'a u t;;
 type 'a u = 'a and 'a v = 'a u t constraint 'a = int;;
+[%%expect {|
+type 'a t constraint 'a = int
+Line _, characters 26-32:
+Error: Constraints are not satisfied in this type.
+       Type 'a u t should be an instance of int t
+|}];;
 
 (* Behaviour is unstable *)
 type g = int;;
 type 'a t = unit constraint 'a = g;;
 type 'a u = 'a and 'a v = 'a u t;;
 type 'a u = 'a and 'a v = 'a u t constraint 'a = int;;
+[%%expect {|
+type g = int
+type 'a t = unit constraint 'a = g
+Line _, characters 26-32:
+Error: Constraints are not satisfied in this type.
+       Type 'a u t should be an instance of g t
+|}];;
 
 (* Example of wrong expansion *)
 type 'a u = < m : 'a v > and 'a v = 'a list u;;
+[%%expect {|
+Line _, characters 0-24:
+Error: In the definition of v, type 'a list u should be 'a u
+|}];;
 
 (* PR#1744: Ctype.matches *)
 type 'a t = 'a
 type 'a u = A of 'a t;;
+[%%expect {|
+type 'a t = 'a
+type 'a u = A of 'a t
+|}];;
 
 (* Unification of cyclic terms *)
 type 'a t = < a : 'a >;;
 fun (x : 'a t as 'a) -> (x : 'b t);;
 type u = 'a t as 'a;;
+[%%expect {|
+type 'a t = < a : 'a >
+- : ('a t as 'a) -> 'a t = 
+type u = 'a t as 'a
+|}, Principal{|
+type 'a t = < a : 'a >
+- : ('a t as 'a) -> ('b t as 'b) t = 
+type u = 'a t as 'a
+|}];;
 
 
 (* Variant tests *)
@@ -445,10 +903,43 @@ function `A, A -> 1 | `B, A -> 2 | _, B -> 3;;
 function (`A|`B), _ -> 0 | _,(`A|`B) -> 1;;
 function `B,1 -> 1 | _,1 -> 2;;
 function 1,`B -> 1 | 1,_ -> 2;;
+[%%expect {|
+type t = A | B
+- : [> `A ] * t -> int = 
+- : [> `A ] * t -> int = 
+- : [> `A ] option * t -> int = 
+- : [> `A ] option * t -> int = 
+- : t * [< `A | `B ] -> int = 
+- : [< `A | `B ] * t -> int = 
+Line _, characters 0-41:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(`AnyExtraTag, `AnyExtraTag)
+- : [> `A | `B ] * [> `A | `B ] -> int = 
+Line _, characters 0-29:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(_, 0)
+Line _, characters 21-24:
+Warning 11: this match case is unused.
+- : [< `B ] * int -> int = 
+Line _, characters 0-29:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(0, _)
+Line _, characters 21-24:
+Warning 11: this match case is unused.
+- : int * [< `B ] -> int = 
+|}];;
 
 (* pass typetexp, but fails during Typedecl.check_recursion *)
 type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b]
 and  ('a, 'b) b = 'b -> unit constraint 'b = [> `A of ('a, 'b) a as 'a];;
+[%%expect {|
+Line _, characters 0-71:
+Error: The definition of a contains a cycle:
+       [> `B of ('a, 'b) b as 'b ] as 'a
+|}];;
 
 (* PR#1917: expanding may change original in Ctype.unify2 *)
 (* Note: since 3.11, the abbreviations are not used when printing
@@ -460,12 +951,45 @@ end and ['a, 'b] b = object
   method a: ('a, 'b) #a as 'a
   method as_b: ('a, 'b) b
 end;;
+[%%expect {|
+class type ['a, 'b] a =
+  object
+    constraint 'a = < as_a : ('a, 'b) a as 'c; b : 'b; .. >
+    constraint 'b = < a : 'a; as_b : ('a, 'b) b; .. >
+    method as_a : 'c
+    method b : 'b
+  end
+and ['a, 'b] b =
+  object
+    constraint 'a = < as_a : ('a, 'b) a; b : 'b; .. >
+    constraint 'b = < a : 'a; as_b : ('a, 'b) b; .. >
+    method a : 'a
+    method as_b : ('a, 'b) b
+  end
+|}];;
 
 class type ['b] ca = object ('s) inherit ['s, 'b] a end;;
 class type ['a] cb = object ('s) inherit ['a, 's] b end;;
+[%%expect {|
+class type ['a] ca =
+  object ('b)
+    constraint 'a = < a : 'b; as_b : ('b, 'a) b; .. >
+    method as_a : ('b, 'a) a
+    method b : 'a
+  end
+class type ['a] cb =
+  object ('b)
+    constraint 'a = < as_a : ('a, 'b) a; b : 'b; .. >
+    method a : 'a
+    method as_b : ('a, 'b) b
+  end
+|}];;
 
 type bt = 'b ca cb as 'b
 ;;
+[%%expect {|
+type bt = 'a ca cb as 'a
+|}];;
 
 (* final classes, etc... *)
 class c = object method m = 1 end;;
@@ -484,6 +1008,19 @@ let o = object (_ : 's)
   method private m =
     object (self: 's) method x = 3 method private m = self end
 end;;
+[%%expect {|
+class c : object method m : int end
+val f : unit -> c = 
+val f : unit -> c = 
+Line _, characters 11-60:
+Warning 15: the following private methods were made public implicitly:
+ n.
+val f : unit -> < m : int; n : int > = 
+Line _, characters 11-56:
+Error: This object is expected to have type c but actually has type
+         < m : int; n : 'a >
+       The first object type has no method n
+|}];;
 
 
 (* Unsound! *)
@@ -494,6 +1031,13 @@ type foo' =   
 type 'a bar =  >
 type bar' =   
 let f (x : foo') = (x : bar');;
+[%%expect {|
+Line _, characters 3-4:
+Error: This expression has type < m : 'a. 'a * < m : 'a * 'b > > as 'b
+       but an expression was expected of type
+         < m : 'a. 'a * (< m : 'a * < m : 'c. 'c * 'd > > as 'd) >
+       Types for method m are incompatible
+|}];;
 
 fun (x :  as 'foo)>) ->
   (x : )> as 'bar);;
@@ -504,6 +1048,14 @@ fun (x :  as 'foo) ->
 let f x =
     (x :  ('a *  'bar> as 'bar)>
        :>  ('a * 'foo)> as 'foo);;
+[%%expect {|
+Line _, characters 3-4:
+Error: This expression has type
+         < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
+       but an expression was expected of type
+         < m : 'b. 'b * ('b * < m : 'c. 'c * ('c * 'd) >) > as 'd
+       Types for method m are incompatible
+|}];;
 
 module M
 : sig val f : ( as 'bar)>) -> unit end
@@ -511,6 +1063,20 @@ module M
 module M
 : sig type t =  as 'bar)> end
 = struct type t =  as 'foo end;;
+[%%expect {|
+Line _, characters 2-64:
+Error: Signature mismatch:
+       Modules do not match:
+         sig val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit end
+       is not included in
+         sig
+           val f : < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > -> unit
+         end
+       Values do not match:
+         val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit
+       is not included in
+         val f : < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > -> unit
+|}];;
 
 module M : sig type 'a t type u =  end
 = struct type 'a t = int type u =  end;;
@@ -519,11 +1085,21 @@ module M : sig type 'a t val f :  -> int end
 (* The following should be accepted too! *)
 module M : sig type 'a t val f :  -> int end
 = struct type 'a t = int let f x = x#m end;;
+[%%expect {|
+module M : sig type 'a t type u = < m : 'a. 'a t > end
+module M : sig type 'a t val f : < m : 'a. 'a t > -> int end
+module M : sig type 'a t val f : < m : 'a. 'a t > -> int end
+|}];;
 
 let f x y =
   ignore (x :>  'c * < > > as 'c);
   ignore (y :>  'd * < > > as 'd);
   x = y;;
+[%%expect {|
+val f :
+  (< m : 'a. 'a -> (< m : 'a. 'a -> 'c * <  > > as 'c) * < .. >; .. > as 'b) ->
+  'b -> bool = 
+|}];;
 
 
 (* Subtyping *)
@@ -540,6 +1116,15 @@ type p = ;;
 type q = private ;;
 fun x -> (x : q :> p);;
 fun x -> (x : p :> q);;
+[%%expect {|
+type t = [ `A | `B ]
+type v = private [> t ]
+- : t -> v = 
+type u = private [< t ]
+- : u -> v = 
+Line _, characters 9-21:
+Error: Type v = [> `A | `B ] is not a subtype of u = [< `A | `B ]
+|}];;
 
 let f1 x =
   (x :  as 'a) -> int>
@@ -555,6 +1140,13 @@ let f5 x =
   (x :  ] as 'a> :>  ] as 'a>);;
 let f6 x =
   (x :  ] as 'a> :>  ] as 'a>);;
+[%%expect {|
+Line _, characters 2-88:
+Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of
+         < m : 'b. (< p : int; q : int; .. > as 'b) -> int >
+       Type < p : int; q : int; .. > as 'c is not a subtype of
+         < p : int; .. > as 'd
+|}];;
 
 (* Keep sharing the epsilons *)
 let f x = if true then (x : < m : 'a. 'a -> 'a >) else x;;
@@ -563,6 +1155,27 @@ let f (x, y) = if true then (x : < m : 'a. 'a -> 'a >) else x;;
 fun x -> (f (x,x))#m;; (* Warning 18 *)
 let f x = if true then [| (x : < m : 'a. 'a -> 'a >) |] else [|x|];;
 fun x -> (f x).(0)#m;; (* Warning 18 *)
+[%%expect {|
+val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > = 
+- : < m : 'a. 'a -> 'a > -> 'b -> 'b = 
+val f : < m : 'a. 'a -> 'a > * 'b -> < m : 'a. 'a -> 'a > = 
+- : < m : 'a. 'a -> 'a > -> 'b -> 'b = 
+val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > array = 
+- : < m : 'a. 'a -> 'a > -> 'b -> 'b = 
+|}, Principal{|
+val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > = 
+Line _, characters 9-16:
+Warning 18: this use of a polymorphic method is not principal.
+- : < m : 'a. 'a -> 'a > -> 'b -> 'b = 
+val f : < m : 'a. 'a -> 'a > * 'b -> < m : 'a. 'a -> 'a > = 
+Line _, characters 9-20:
+Warning 18: this use of a polymorphic method is not principal.
+- : < m : 'a. 'a -> 'a > -> 'b -> 'b = 
+val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > array = 
+Line _, characters 9-20:
+Warning 18: this use of a polymorphic method is not principal.
+- : < m : 'a. 'a -> 'a > -> 'b -> 'b = 
+|}];;
 
 (* Not really principal? *)
 class c = object method id : 'a. 'a -> 'a = fun x -> x end;;
@@ -575,11 +1188,35 @@ let g x =
 let h x =
   let none = let y = None in ignore [y;(None:u)]; y in
   let x = List.hd [Some x; none] in (just x)#id;;
+[%%expect {|
+class c : object method id : 'a -> 'a end
+type u = c option
+val just : 'a option -> 'a = 
+val f : c -> 'a -> 'a = 
+val g : c -> 'a -> 'a = 
+val h : < id : 'a; .. > -> 'a = 
+|}, Principal{|
+class c : object method id : 'a -> 'a end
+type u = c option
+val just : 'a option -> 'a = 
+Line _, characters 42-62:
+Warning 18: this use of a polymorphic method is not principal.
+val f : c -> 'a -> 'a = 
+Line _, characters 36-47:
+Warning 18: this use of a polymorphic method is not principal.
+val g : c -> 'a -> 'a = 
+val h : < id : 'a; .. > -> 'a = 
+|}];;
 
 (* Only solved for parameterless abbreviations *)
 type 'a u = c option;;
 let just = function None -> failwith "just" | Some x -> x;;
 let f x = let l = [Some x; (None : _ u)] in (just(List.hd l))#id;;
+[%%expect {|
+type 'a u = c option
+val just : 'a option -> 'a = 
+val f : c -> 'a -> 'a = 
+|}];;
 
 (* polymorphic recursion *)
 
@@ -601,20 +1238,45 @@ and q () = r;;
 let f : 'a. _ -> _ = fun x -> x;;
 let zero : 'a. [> `Int of int | `B of 'a] as 'a  = `Int 0;; (* ok *)
 let zero : 'a. [< `Int of int] as 'a = `Int 0;; (* fails *)
+[%%expect {|
+val f : 'a -> int = 
+val g : 'a -> int = 
+type 'a t = Leaf of 'a | Node of ('a * 'a) t
+val depth : 'a t -> int = 
+Line _, characters 2-42:
+Error: This definition has type 'a t -> int which is less general than
+         'a0. 'a0 t -> int
+|}];;
 
 (* compare with records (should be the same) *)
 type t = {f: 'a. [> `Int of int | `B of 'a] as 'a}
 let zero = {f = `Int 0} ;;
 type t = {f: 'a. [< `Int of int] as 'a}
 let zero = {f = `Int 0} ;; (* fails *)
+[%%expect {|
+type t = { f : 'a. [> `B of 'a | `Int of int ] as 'a; }
+val zero : t = {f = `Int 0}
+type t = { f : 'a. [< `Int of int ] as 'a; }
+Line _, characters 16-22:
+Error: This expression has type [> `Int of int ]
+       but an expression was expected of type [< `Int of int ]
+       Types for tag `Int are incompatible
+|}];;
 
 (* Yet another example *)
 let rec id : 'a. 'a -> 'a = fun x -> x
 and neg i b = (id (-i), id (not b));;
+[%%expect {|
+val id : 'a -> 'a = 
+val neg : int -> bool -> int * bool = 
+|}];;
 
 (* De Xavier *)
 
 type t = A of int | B of (int*t) list | C of (string*t) list
+[%%expect {|
+type t = A of int | B of (int * t) list | C of (string * t) list
+|}];;
 
 let rec transf f = function
   | A x -> f x
@@ -624,16 +1286,31 @@ and transf_alist : 'a. _ -> ('a*t) list -> ('a*t) list = fun f -> function
   | [] -> []
   | (k,v)::tl -> (k, transf f v) :: transf_alist f tl
 ;;
+[%%expect {|
+val transf : (int -> t) -> t -> t = 
+val transf_alist : (int -> t) -> ('a * t) list -> ('a * t) list = 
+|}];;
 
 (* PR#4862 *)
 
 type t = {f: 'a. ('a list -> int) Lazy.t}
 let l : t = { f = lazy (raise Not_found)};;
+[%%expect {|
+type t = { f : 'a. ('a list -> int) Lazy.t; }
+val l : t = {f = }
+|}];;
 
 (* variant *)
 type t = {f: 'a. 'a -> unit};;
 let f ?x y = () in {f};;
 let f ?x y = y in {f};; (* fail *)
+[%%expect {|
+type t = { f : 'a. 'a -> unit; }
+- : t = {f = }
+Line _, characters 19-20:
+Error: This field value has type unit -> unit which is less general than
+         'a. 'a -> unit
+|}];;
 
 (* Polux Moon caml-list 2011-07-26 *)
 module Polux = struct
@@ -642,6 +1319,15 @@ module Polux = struct
   class alias = object method alias : 'a . 'a t -> 'a = ident end
   let f (x : ) = (x : )
 end;;
+[%%expect {|
+module Polux :
+  sig
+    type 'par t = 'par
+    val ident : 'a -> 'a
+    class alias : object method alias : 'a t -> 'a end
+    val f : < m : 'a. 'a t > -> < m : 'a. 'a >
+  end
+|}];;
 
 (* PR#5560 *)
 
@@ -650,10 +1336,17 @@ type t = { foo : int }
 let {foo} = (raise Exit : t);;
 type s = A of int
 let (A x) = (raise Exit : s);;
+[%%expect {|
+Exception: Pervasives.Exit.
+|}];;
 
 (* PR#5224 *)
 
 type 'x t = < f : 'y. 'y t >;;
+[%%expect {|
+Line _, characters 0-28:
+Error: In the definition of t, type 'y t should be 'x t
+|}];;
 
 (* PR#6056, PR#6057 *)
 let using_match b =
@@ -664,26 +1357,93 @@ let using_match b =
   in
   f 0,f
 ;;
+[%%expect {|
+val using_match : bool -> int * ('a -> 'a) = 
+|}];;
 
 match (fun x -> x), fun x -> x with x, y -> x, y;;
 match fun x -> x with x -> x, x;;
+[%%expect {|
+- : ('a -> 'a) * ('b -> 'b) = (, )
+- : ('a -> 'a) * ('b -> 'b) = (, )
+|}];;
 
 (* PR#6747 *)
 (* ok *)
 let n = object
   method m : 'x 'o. ([< `Foo of 'x] as 'o) -> 'x = fun x -> assert false
 end;;
+[%%expect {|
+val n : < m : 'x 'a. ([< `Foo of 'x ] as 'a) -> 'x > = 
+|}];;
 (* ok, but not with -principal *)
 let n =
   object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;;
+[%%expect {|
+val n : < m : 'x. [< `Foo of 'x ] -> 'x > = 
+|}, Principal{|
+Line _, characters 47-68:
+Error: This method has type ([< `Foo of 'b ] as 'a) -> 'b
+       which is less general than 'x. 'a -> 'x
+|}];;
 (* fail *)
 let (n : < m : 'a. [< `Foo of int] -> 'a >) =
   object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;;
+[%%expect {|
+Line _, characters 2-72:
+Error: This expression has type < m : 'x. [< `Foo of 'x ] -> 'x >
+       but an expression was expected of type
+         < m : 'a. [< `Foo of int ] -> 'a >
+       The universal variable 'x would escape its scope
+|}, Principal{|
+Line _, characters 47-68:
+Error: This method has type ([< `Foo of 'b ] as 'a) -> 'b
+       which is less general than 'x. 'a -> 'x
+|}];;
 (* fail *)
 let (n : 'b -> < m : 'a . ([< `Foo of int] as 'b) -> 'a >) = fun x ->
   object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;;
+[%%expect {|
+Line _, characters 2-72:
+Error: This expression has type < m : 'x. [< `Foo of 'x ] -> 'x >
+       but an expression was expected of type
+         < m : 'a. [< `Foo of int ] -> 'a >
+       The universal variable 'x would escape its scope
+|}, Principal{|
+Line _, characters 47-68:
+Error: This method has type ([< `Foo of 'b ] as 'a) -> 'b
+       which is less general than 'x. 'a -> 'x
+|}];;
 
 (* PR#6171 *)
 let f b (x: 'x) =
   let module M = struct type t = A end in
   if b then x else M.A;;
+[%%expect {|
+Line _, characters 19-22:
+Error: This expression has type M.t but an expression was expected of type 'x
+       The type constructor M.t would escape its scope
+|}];;
+
+(* PR#7285 *)
+type (+'a,-'b) foo = private int;;
+let f (x : int) : ('a,'a) foo = Obj.magic x;;
+let x = f 3;;
+[%%expect{|
+type (+'a, -'b) foo = private int
+val f : int -> ('a, 'a) foo = 
+val x : ('_a, '_a) foo = 3
+|}]
+
+(* PR#7395 *)
+type u
+type 'a t = u;;
+let c (f : u -> u) =
+ object
+   method apply: 'a. 'a t -> 'a t = fun x -> f x
+ end;;
+[%%expect{|
+type u
+type 'a t = u
+val c : (u -> u) -> < apply : 'a. 'a t -> 'a t > = 
+|}]
diff --git a/testsuite/tests/typing-poly/poly.ml.principal.reference b/testsuite/tests/typing-poly/poly.ml.principal.reference
deleted file mode 100644
index d8525934..00000000
--- a/testsuite/tests/typing-poly/poly.ml.principal.reference
+++ /dev/null
@@ -1,675 +0,0 @@
-
-# * * *       #   type 'a t = { t : 'a; }
-# type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b; }
-# val f : 'a list -> 'a fold = 
-# - : int = 6
-#               class ['b] ilist :
-  'b list ->
-  object ('c)
-    val l : 'b list
-    method add : 'b -> 'c
-    method fold : f:('a -> 'b -> 'a) -> init:'a -> 'a
-  end
-#         class virtual ['a] vlist :
-  object ('c)
-    method virtual add : 'a -> 'c
-    method virtual fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
-  end
-#             class ilist2 :
-  int list ->
-  object ('a)
-    val l : int list
-    method add : int -> 'a
-    method fold : f:('b -> int -> 'b) -> init:'b -> 'b
-  end
-#             val ilist2 : 'a list -> 'a vlist = 
-#             class ['a] ilist3 :
-  'a list ->
-  object ('c)
-    val l : 'a list
-    method add : 'a -> 'c
-    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
-  end
-#               class ['a] ilist4 :
-  'a list ->
-  object ('c)
-    val l : 'a list
-    method add : 'a -> 'c
-    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
-  end
-#                 class ['a] ilist5 :
-  'a list ->
-  object ('c)
-    val l : 'a list
-    method add : 'a -> 'c
-    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
-    method fold2 : f:('b -> 'a -> 'b) -> init:'b -> 'b
-  end
-#                 class ['a] ilist6 :
-  'a list ->
-  object ('c)
-    val l : 'a list
-    method add : 'a -> 'c
-    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
-    method fold2 : f:('b -> 'a -> 'b) -> init:'b -> 'b
-  end
-#       class virtual ['a] olist :
-  object method virtual fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end
-#         class ['a] onil :
-  object method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end
-#             class ['a] ocons :
-  hd:'a ->
-  tl:'a olist ->
-  object
-    val hd : 'a
-    val tl : 'a olist
-    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
-  end
-#               class ['a] ostream :
-  hd:'a ->
-  tl:'a ostream ->
-  object
-    val hd : 'a
-    val tl : < empty : bool; fold : 'c. f:('a -> 'c -> 'c) -> init:'c -> 'c >
-    method empty : bool
-    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
-  end
-#                   Characters 166-178:
-      self#tl#fold ~f ~init:(f self#hd init)
-      ^^^^^^^^^^^^
-Warning 18: this use of a polymorphic method is not principal.
-class ['a] ostream1 :
-  hd:'a ->
-  tl:'b ->
-  object ('b)
-    val hd : 'a
-    val tl : 'b
-    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
-    method hd : 'a
-    method tl : 'b
-  end
-#           class vari : object method m : [< `A | `B | `C ] -> int end
-#       class vari : object method m : [< `A | `B | `C ] -> int end
-#           module V : sig type v = [ `A | `B | `C ] val m : [< v ] -> int end
-#         class varj : object method m : [< V.v ] -> int end
-#         module type T =
-  sig class vari : object method m : [< `A | `B | `C ] -> int end end
-#             module M0 :
-  sig class vari : object method m : [< `A | `B | `C ] -> int end end
-#   module M : T
-# val v : M.vari = 
-# - : int = 1
-#               class point :
-  x:int ->
-  y:int -> object val x : int val y : int method x : int method y : int end
-#           class color_point :
-  x:int ->
-  y:int ->
-  color:string ->
-  object
-    val color : string
-    val x : int
-    val y : int
-    method color : string
-    method x : int
-    method y : int
-  end
-#                   class circle :
-  #point ->
-  r:int ->
-  object val p : point val r : int method distance : #point -> float end
-#           val p0 : point = 
-val p1 : point = 
-val cp : color_point = 
-val c : circle = 
-val d : float = 11.
-#   val f : < m : 'a. 'a -> 'a > -> < m : 'b. 'b -> 'b > = 
-#   Characters 41-42:
-  let f (x : < m : 'a. 'a -> 'a list >) = (x : < m : 'b. 'b -> 'c >)
-                                           ^
-Error: This expression has type < m : 'b. 'b -> 'b list >
-       but an expression was expected of type < m : 'b. 'b -> 'c >
-       The universal variable 'b would escape its scope
-#           class id : object method id : 'a -> 'a end
-#         class type id_spec = object method id : 'a -> 'a end
-#       class id_impl : object method id : 'a -> 'a end
-#               class a : object method m : bool end
-and b : object method id : 'a -> 'a end
-#           Characters 72-77:
-    method id x = x
-              ^^^^^
-Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
-#         Characters 75-80:
-    method id x = x
-              ^^^^^
-Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
-#           Characters 80-85:
-    method id _ = x
-              ^^^^^
-Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a
-#                 Characters 92-159:
-  ............x =
-      match r with
-        None -> r <- Some x; x
-      | Some y -> y
-Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a
-#         class c : object method m : 'a -> 'b -> 'a end
-#     val f1 : id -> int * bool = 
-#   val f2 : id -> int * bool = 
-#   Characters 24-28:
-  let f3 f = f#id 1, f#id true
-                          ^^^^
-Error: This expression has type bool but an expression was expected of type
-         int
-#   Characters 27-31:
-  let f4 f = ignore(f : id); f#id 1, f#id true
-                             ^^^^
-Warning 18: this use of a polymorphic method is not principal.
-Characters 35-39:
-  let f4 f = ignore(f : id); f#id 1, f#id true
-                                     ^^^^
-Warning 18: this use of a polymorphic method is not principal.
-val f4 : id -> int * bool = 
-#           class c : object method m : #id -> int * bool end
-#             class id2 : object method id : 'a -> 'a method mono : int -> int end
-#   val app : int * bool = (1, true)
-#   Characters 0-25:
-  type 'a foo = 'a foo list
-  ^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: The type abbreviation foo is cyclic
-#     class ['a] bar : 'a -> object  end
-#   type 'a foo = 'a foo bar
-#   - : (< m : 'a. 'a * 'b > as 'b) -> 'c * (< m : 'a. 'a * 'd > as 'd) = 
-# - : (< m : 'a. 'b * 'a list > as 'b) ->
-    (< m : 'a. 'c * 'a list > as 'c) * 'd list
-= 
-# val f :
-  (< m : 'b. 'a * (< n : 'b; .. > as 'b) > as 'a) ->
-  (< m : 'd. 'c * (< n : 'd; .. > as 'd) > as 'c) * (< n : 'e; .. > as 'e) =
-  
-# - : (< p : 'b. < m : 'b; n : 'a; .. > as 'b > as 'a) ->
-    (< m : 'c; n : < p : 'e. < m : 'e; n : 'd; .. > as 'e > as 'd; .. > as 'c)
-= 
-# - : (< m : 'a. 'a * < p : 'b. 'b * 'd * 'c > as 'd > as 'c) ->
-    ('f *
-     < p : 'b.
-             'b * 'e *
-             (< m : 'a. 'a * < p : 'b0. 'b0 * 'h * 'g > as 'h > as 'g) >
-     as 'e)
-= 
-#   - : < m : 'a. < p : 'a; .. > as 'b > -> 'b = 
-#   type sum = T of < id : 'a. 'a -> 'a >
-# - : sum -> 'a -> 'a = 
-#   type record = { r : < id : 'a. 'a -> 'a >; }
-# - : record -> 'a -> 'a = 
-# - : record -> 'a -> 'a = 
-#       class myself : object ('b) method self : 'a -> 'b end
-#                       class number :
-  object ('b)
-    val num : int
-    method num : int
-    method prev : 'b
-    method succ : 'b
-    method switch : zero:(unit -> 'a) -> prev:('b -> 'a) -> 'a
-  end
-#     val id : 'a -> 'a = 
-#       class c : object method id : 'a -> 'a end
-#         class c' : object method id : 'a -> 'a end
-#               class d :
-  object
-    val mutable count : int
-    method count : int
-    method id : 'a -> 'a
-    method old : 'a -> 'a
-  end
-#             class ['a] olist :
-  'a list ->
-  object ('c)
-    val l : 'a list
-    method cons : 'a -> 'c
-    method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b
-  end
-#   val sum : int #olist -> int = 
-#   val count : 'a #olist -> int = 
-#     val append : 'a #olist -> ('a #olist as 'b) -> 'b = 
-#     type 'a t = unit
-#   class o : object method x : [> `A ] t -> unit end
-#   class c : object method m : d end
-and d : ?x:int -> unit -> object  end
-# class d : ?x:int -> unit -> object  end
-and c : object method m : d end
-#           class type numeral = object method fold : ('a -> 'a) -> 'a -> 'a end
-class zero : object method fold : ('a -> 'a) -> 'a -> 'a end
-class next : #numeral -> object method fold : ('a -> 'a) -> 'a -> 'a end
-#       class type node_type = object method as_variant : [> `Node of node_type ] end
-#       class node : node_type
-#     class node : object method as_variant : [> `Node of node_type ] end
-#   type bad = { bad : 'a. 'a option ref; }
-# Characters 17-25:
-  let bad = {bad = ref None};;
-                   ^^^^^^^^
-Error: This field value has type 'b option ref which is less general than
-         'a. 'a option ref
-# type bad2 = { mutable bad2 : 'a. 'a option ref option; }
-# val bad2 : bad2 = {bad2 = None}
-# Characters 13-28:
-  bad2.bad2 <- Some (ref None);;
-               ^^^^^^^^^^^^^^^
-Error: This field value has type 'b option ref option
-       which is less general than 'a. 'a option ref option
-#       val f : < m : 'a. < p : 'a * 'c > as 'c > -> 'b -> unit = 
-# val f :
-  < m : 'a. 'a * (< p : int * 'b > as 'b) > ->
-  (< p : int * 'c > as 'c) -> unit = 
-#       type 'a t = [ `A of 'a ]
-#       class c : object method m : ([> 'a t ] as 'a) -> unit end
-#         class c : object method m : ([> 'a t ] as 'a) -> unit end
-#     class c : object method m : ([> 'a t ] as 'a) -> 'a end
-#     class c : object method m : ([> `A ] as 'a) option -> 'a end
-#           Characters 145-166:
-  object method virtual visit : 'a.('a visitor -> 'a) end;;
-                                ^^^^^^^^^^^^^^^^^^^^^
-Error: The universal type variable 'a cannot be generalized:
-       it escapes its scope.
-#                 type ('a, 'b) list_visitor = < caseCons : 'b -> 'b list -> 'a; caseNil : 'a >
-type 'b alist = < visit : 'a. ('a, 'b) list_visitor -> 'a >
-class type ct = object ('a) method fold : ('b -> 'a -> 'b) -> 'b -> 'b end
-type t = { f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b; }
-#     Characters 15-25:
-  type t = u and u = t;;
-  ^^^^^^^^^^
-Error: The type abbreviation t is cyclic
-#       class ['a] a : object constraint 'a = [> `A of 'a a ] end
-type t = [ `A of t a ]
-#     Characters 71-80:
-  type ('a,'b) t constraint 'a = 'b and ('a,'b) u = ('a,'b) t;;
-                                                    ^^^^^^^^^
-Error: Constraints are not satisfied in this type.
-       Type ('a, 'b) t should be an instance of ('c, 'c) t
-#     type 'a t = 'a
-and u = int t
-#     type 'a t constraint 'a = int
-# Characters 26-32:
-  type 'a u = 'a and 'a v = 'a u t;;
-                            ^^^^^^
-Error: Constraints are not satisfied in this type.
-       Type 'a u t should be an instance of int t
-# type 'a u = 'a constraint 'a = int
-and 'a v = 'a u t constraint 'a = int
-#     type g = int
-# type 'a t = unit constraint 'a = g
-# Characters 26-32:
-  type 'a u = 'a and 'a v = 'a u t;;
-                            ^^^^^^
-Error: Constraints are not satisfied in this type.
-       Type 'a u t should be an instance of g t
-# type 'a u = 'a constraint 'a = g
-and 'a v = 'a u t constraint 'a = g
-#     Characters 34-58:
-  type 'a u = < m : 'a v > and 'a v = 'a list u;;
-  ^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In the definition of v, type 'a list u should be 'a u
-#       type 'a t = 'a
-type 'a u = A of 'a t
-#     type 'a t = < a : 'a >
-# - : ('a t as 'a) -> ('b t as 'b) t = 
-# type u = 'a t as 'a
-#       type t = A | B
-# - : [> `A ] * t -> int = 
-# - : [> `A ] * t -> int = 
-# - : [> `A ] option * t -> int = 
-#   - : [> `A ] option * t -> int = 
-# - : t * [< `A | `B ] -> int = 
-# - : [< `A | `B ] * t -> int = 
-# Characters 0-41:
-  function (`A|`B), _ -> 0 | _,(`A|`B) -> 1;;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(`AnyExtraTag, `AnyExtraTag)
-- : [> `A | `B ] * [> `A | `B ] -> int = 
-# Characters 0-29:
-  function `B,1 -> 1 | _,1 -> 2;;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(_, 0)
-Characters 21-24:
-  function `B,1 -> 1 | _,1 -> 2;;
-                       ^^^
-Warning 11: this match case is unused.
-- : [< `B ] * int -> int = 
-# Characters 0-29:
-  function 1,`B -> 1 | 1,_ -> 2;;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(0, _)
-Characters 21-24:
-  function 1,`B -> 1 | 1,_ -> 2;;
-                       ^^^
-Warning 11: this match case is unused.
-- : int * [< `B ] -> int = 
-#       Characters 64-135:
-  type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b]
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Constraints are not satisfied in this type.
-       Type
-       ([> `B of 'a ], 'a) b as 'a
-       should be an instance of
-       (('b, [> `A of ('d, 'c) a as 'd ] as 'c) a as 'b, 'c) b
-#     *               class type ['a, 'b] a =
-  object
-    constraint 'a = < as_a : ('a, 'b) a as 'c; b : 'b; .. >
-    constraint 'b = < a : 'a; as_b : ('a, 'b) b; .. >
-    method as_a : 'c
-    method b : 'b
-  end
-and ['a, 'b] b =
-  object
-    constraint 'a = < as_a : ('a, 'b) a; b : 'b; .. >
-    constraint 'b = < a : 'a; as_b : ('a, 'b) b; .. >
-    method a : 'a
-    method as_b : ('a, 'b) b
-  end
-#   class type ['a] ca =
-  object ('b)
-    constraint 'a = < a : 'b; as_b : ('b, 'a) b; .. >
-    method as_a : ('b, 'a) a
-    method b : 'a
-  end
-# class type ['a] cb =
-  object ('b)
-    constraint 'a = < as_a : ('a, 'b) a; b : 'b; .. >
-    method a : 'a
-    method as_b : ('a, 'b) b
-  end
-#     type bt = 'a ca cb as 'a
-#     class c : object method m : int end
-# val f : unit -> c = 
-# val f : unit -> c = 
-# Characters 11-60:
-  let f () = object method private n = 1 method m = {<>}#n end;;
-             ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 15: the following private methods were made public implicitly:
- n.
-val f : unit -> < m : int; n : int > = 
-# Characters 11-56:
-  let f () = object (self:c) method n = 1 method m = 2 end;;
-             ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This object is expected to have type c but actually has type
-         < m : int; n : 'a >
-       The first object type has no method n
-# Characters 11-69:
-  let f () = object (_:'s) constraint 's = < n : int > method m = 1 end;;
-             ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This object is expected to have type < n : int > but actually has type
-         < m : 'a >
-       The second object type has no method n
-#         Characters 66-124:
-      object (self: 's) method x = 3 method private m = self end
-      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This object is expected to have type < x : int; .. >
-       but actually has type < x : int >
-       Self type cannot be unified with a closed object type
-#         val o : < x : int > = 
-#         Characters 76-77:
-    (x :  > as 'bar) >);;
-     ^
-Error: This expression has type < m : 'a. 'a * < m : 'a * 'b > > as 'b
-       but an expression was expected of type
-         < m : 'a. 'a * (< m : 'a * < m : 'c. 'c * 'd > > as 'd) >
-       Types for method m are incompatible
-#         Characters 176-177:
-  let f (x : foo') = (x : bar');;
-                      ^
-Error: This expression has type foo' = < m : 'a. 'a * 'a foo >
-       but an expression was expected of type bar' = < m : 'a. 'a * 'a bar >
-       Type 'a foo = < m : 'a * 'a foo > is not compatible with type
-         'a bar = < m : 'a * < m : 'c. 'c * 'a bar > > 
-       Type 'a foo = < m : 'a * 'a foo > is not compatible with type
-         < m : 'c. 'c * 'a bar > 
-       Types for method m are incompatible
-#     Characters 67-68:
-    (x : )> as 'bar);;
-     ^
-Error: This expression has type
-         < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
-       but an expression was expected of type
-         < m : 'b. 'b * ('b * < m : 'c. 'c * ('c * 'd) >) > as 'd
-       Types for method m are incompatible
-#   Characters 66-67:
-    (x : )> as 'bar);;
-     ^
-Error: This expression has type
-         < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
-       but an expression was expected of type
-         < m : 'b. 'b * ('b * < m : 'c. 'c * ('b * 'd) >) > as 'd
-       Types for method m are incompatible
-#   Characters 51-52:
-    (x :  as 'bar)>);;
-     ^
-Error: This expression has type < m : 'b. 'b * ('b * 'a) > as 'a
-       but an expression was expected of type
-         < m : 'b. 'b * ('b * < m : 'c. 'c * 'd > as 'd) >
-       Types for method m are incompatible
-#     Characters 14-115:
-  ....(x :  ('a *  'bar> as 'bar)>
-         :>  ('a * 'foo)> as 'foo)..
-Error: Type < m : 'a. 'a -> ('a * (< m : 'c. 'c -> 'b as 'e > as 'd) as 'b) >
-       is not a subtype of < m : 'a. 'a -> ('a * 'f as 'h) as 'g > as 'f 
-       Type 'c. 'e is not a subtype of 'a. 'g 
-#       Characters 88-150:
-  = struct let f (x :  as 'foo) = () end;;
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Signature mismatch:
-       Modules do not match:
-         sig val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit end
-       is not included in
-         sig
-           val f : < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > -> unit
-         end
-       Values do not match:
-         val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit
-       is not included in
-         val f : < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > -> unit
-#     Characters 78-132:
-  = struct type t =  as 'foo end;;
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Signature mismatch:
-       Modules do not match:
-         sig type t = < m : 'a. 'a * ('a * 'b) > as 'b end
-       is not included in
-         sig type t = < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > end
-       Type declarations do not match:
-         type t = < m : 'a. 'a * ('a * 'b) > as 'b
-       is not included in
-         type t = < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
-#     module M : sig type 'a t type u = < m : 'a. 'a t > end
-#   module M : sig type 'a t val f : < m : 'a. 'a t > -> int end
-#     module M : sig type 'a t val f : < m : 'a. 'a t > -> int end
-#         val f :
-  (< m : 'a. 'a -> (< m : 'a. 'a -> 'c * <  > > as 'c) * < .. >; .. > as 'b) ->
-  'b -> bool = 
-#         type t = [ `A | `B ]
-# type v = private [> t ]
-# - : t -> v = 
-# type u = private [< t ]
-# - : u -> v = 
-# Characters 9-21:
-  fun x -> (x : v :> u);;
-           ^^^^^^^^^^^^
-Error: Type v = [> `A | `B ] is not a subtype of u = [< `A | `B ] 
-# type v = private [< t ]
-# Characters 9-21:
-  fun x -> (x : u :> v);;
-           ^^^^^^^^^^^^
-Error: Type u = [< `A | `B ] is not a subtype of v = [< `A | `B ] 
-# type p = < x : p >
-# type q = private < x : p; .. >
-# - : q -> p = 
-# Characters 9-21:
-  fun x -> (x : p :> q);;
-           ^^^^^^^^^^^^
-Error: Type p = < x : p > is not a subtype of q = < x : p; .. > 
-#       Characters 14-100:
-  ..(x :  as 'a) -> int>
-      :>  as 'b) -> int>)..
-Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of
-         < m : 'b. (< p : int; q : int; .. > as 'b) -> int > 
-       Type < p : int; q : int; .. > as 'c is not a subtype of
-         < p : int; .. > as 'd 
-#     val f2 :
-  < m : 'a. (< p : < a : int >; .. > as 'a) -> int > ->
-  < m : 'b. (< p : < a : int; b : int >; .. > as 'b) -> int > = 
-#     Characters 13-107:
-  ..(x : ;..> as 'a) -> int>
-      :> ;..> as 'b) -> int>)..
-Error: Type < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int >
-       is not a subtype of < m : 'b. (< p : < a : int >; .. > as 'b) -> int > 
-       Type < a : int > is not a subtype of < a : int; b : int > 
-# Characters 11-55:
-  let f4 x = (x : ;..> :> ;..>);;
-             ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Type < p : < a : int; b : int >; .. > is not a subtype of
-         < p : < a : int >; .. > 
-       The second object type has no method b
-#   val f5 :
-  < m : 'a. [< `A of < p : int > ] as 'a > ->
-  < m : 'b. [< `A of <  > ] as 'b > = 
-#   Characters 13-83:
-    (x :  ] as 'a> :>  ] as 'a>);;
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Type < m : 'a. [< `A of <  > ] as 'a > is not a subtype of
-         < m : 'b. [< `A of < p : int > ] as 'b > 
-       Type <  > is not a subtype of < p : int > 
-#     val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > = 
-# Characters 9-16:
-  fun x -> (f x)#m;; (* Warning 18 *)
-           ^^^^^^^
-Warning 18: this use of a polymorphic method is not principal.
-- : < m : 'a. 'a -> 'a > -> 'b -> 'b = 
-# val f : < m : 'a. 'a -> 'a > * 'b -> < m : 'a. 'a -> 'a > = 
-# Characters 9-20:
-  fun x -> (f (x,x))#m;; (* Warning 18 *)
-           ^^^^^^^^^^^
-Warning 18: this use of a polymorphic method is not principal.
-- : < m : 'a. 'a -> 'a > -> 'b -> 'b = 
-# val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > array = 
-# Characters 9-20:
-  fun x -> (f x).(0)#m;; (* Warning 18 *)
-           ^^^^^^^^^^^
-Warning 18: this use of a polymorphic method is not principal.
-- : < m : 'a. 'a -> 'a > -> 'b -> 'b = 
-#     class c : object method id : 'a -> 'a end
-# type u = c option
-# val just : 'a option -> 'a = 
-# Characters 42-62:
-  let f x = let l = [Some x; (None : u)] in (just(List.hd l))#id;;
-                                            ^^^^^^^^^^^^^^^^^^^^
-Warning 18: this use of a polymorphic method is not principal.
-val f : c -> 'a -> 'a = 
-#     Characters 101-112:
-    let x = List.hd [Some x; none] in (just x)#id;;
-                                      ^^^^^^^^^^^
-Warning 18: this use of a polymorphic method is not principal.
-val g : c -> 'a -> 'a = 
-#     val h : < id : 'a; .. > -> 'a = 
-#     type 'a u = c option
-# val just : 'a option -> 'a = 
-# val f : c -> 'a -> 'a = 
-#       val f : 'a -> int = 
-val g : 'a -> int = 
-# type 'a t = Leaf of 'a | Node of ('a * 'a) t
-#   val depth : 'a t -> int = 
-#     Characters 34-74:
-    function Leaf _ -> 1 | Node x -> 1 + d x
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This definition has type 'a t -> int which is less general than
-         'a0. 'a0 t -> int
-#   Characters 34-78:
-    function Leaf x -> x | Node x -> 1 + depth x;; (* fails *)
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This definition has type int t -> int which is less general than
-         'a. 'a t -> int
-#   Characters 34-74:
-    function Leaf x -> x | Node x -> depth x;; (* fails *)
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This definition has type 'a t -> 'a which is less general than
-         'a0. 'a0 t -> 'a
-#   Characters 38-78:
-    function Leaf x -> x | Node x -> depth x;; (* fails *)
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This definition has type 'b. 'b t -> 'b which is less general than
-         'a 'b. 'a t -> 'b
-#   val r : 'a list * '_b list ref = ([], {contents = []})
-val q : unit -> 'a list * '_b list ref = 
-# val f : 'a -> 'a = 
-# val zero : [> `B of 'a | `Int of int ] as 'a = `Int 0
-# Characters 39-45:
-  let zero : 'a. [< `Int of int] as 'a = `Int 0;; (* fails *)
-                                         ^^^^^^
-Error: This expression has type [> `Int of int ]
-       but an expression was expected of type [< `Int of int ]
-       Types for tag `Int are incompatible
-#       type t = { f : 'a. [> `B of 'a | `Int of int ] as 'a; }
-val zero : t = {f = `Int 0}
-#   Characters 56-62:
-  let zero = {f = `Int 0} ;; (* fails *)
-                  ^^^^^^
-Error: This expression has type [> `Int of int ]
-       but an expression was expected of type [< `Int of int ]
-       Types for tag `Int are incompatible
-#       val id : 'a -> 'a = 
-val neg : int -> bool -> int * bool = 
-#                         type t = A of int | B of (int * t) list | C of (string * t) list
-val transf : (int -> t) -> t -> t = 
-val transf_alist : (int -> t) -> ('a * t) list -> ('a * t) list = 
-#         type t = { f : 'a. ('a list -> int) Lazy.t; }
-val l : t = {f = }
-#     type t = { f : 'a. 'a -> unit; }
-# - : t = {f = }
-# Characters 19-20:
-  let f ?x y = y in {f};; (* fail *)
-                     ^
-Error: This field value has type unit -> unit which is less general than
-         'a. 'a -> unit
-#               module Polux :
-  sig
-    type 'par t = 'par
-    val ident : 'a -> 'a
-    class alias : object method alias : 'a t -> 'a end
-    val f : < m : 'a. 'a t > -> < m : 'a. 'a >
-  end
-#       Exception: Pervasives.Exit.
-#   Exception: Pervasives.Exit.
-#   Exception: Pervasives.Exit.
-#       Characters 16-44:
-  type 'x t = < f : 'y. 'y t >;;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In the definition of t, type 'y t should be 'x t
-#                   val using_match : bool -> int * ('a -> 'a) = 
-#   - : ('a -> 'a) * ('b -> 'b) = (, )
-# - : ('a -> 'a) * ('b -> 'b) = (, )
-#           val n : < m : 'x 'a. ([< `Foo of 'x ] as 'a) -> 'x > = 
-#     Characters 89-110:
-    object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;;
-                                                 ^^^^^^^^^^^^^^^^^^^^^
-Error: This method has type ([< `Foo of 'b ] as 'a) -> 'b
-       which is less general than 'x. 'a -> 'x
-#     Characters 104-125:
-    object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;;
-                                                 ^^^^^^^^^^^^^^^^^^^^^
-Error: This method has type ([< `Foo of 'b ] as 'a) -> 'b
-       which is less general than 'x. 'a -> 'x
-#     Characters 128-149:
-    object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;;
-                                                 ^^^^^^^^^^^^^^^^^^^^^
-Error: This method has type ([< `Foo of 'b ] as 'a) -> 'b
-       which is less general than 'x. 'a -> 'x
-#         Characters 94-97:
-    if b then x else M.A;;
-                     ^^^
-Error: This expression has type M.t but an expression was expected of type 'x
-       The type constructor M.t would escape its scope
-# 
diff --git a/testsuite/tests/typing-poly/poly.ml.reference b/testsuite/tests/typing-poly/poly.ml.reference
deleted file mode 100644
index fd968116..00000000
--- a/testsuite/tests/typing-poly/poly.ml.reference
+++ /dev/null
@@ -1,629 +0,0 @@
-
-# * * *       #   type 'a t = { t : 'a; }
-# type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b; }
-# val f : 'a list -> 'a fold = 
-# - : int = 6
-#               class ['b] ilist :
-  'b list ->
-  object ('c)
-    val l : 'b list
-    method add : 'b -> 'c
-    method fold : f:('a -> 'b -> 'a) -> init:'a -> 'a
-  end
-#         class virtual ['a] vlist :
-  object ('c)
-    method virtual add : 'a -> 'c
-    method virtual fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
-  end
-#             class ilist2 :
-  int list ->
-  object ('a)
-    val l : int list
-    method add : int -> 'a
-    method fold : f:('b -> int -> 'b) -> init:'b -> 'b
-  end
-#             val ilist2 : 'a list -> 'a vlist = 
-#             class ['a] ilist3 :
-  'a list ->
-  object ('c)
-    val l : 'a list
-    method add : 'a -> 'c
-    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
-  end
-#               class ['a] ilist4 :
-  'a list ->
-  object ('c)
-    val l : 'a list
-    method add : 'a -> 'c
-    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
-  end
-#                 class ['a] ilist5 :
-  'a list ->
-  object ('c)
-    val l : 'a list
-    method add : 'a -> 'c
-    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
-    method fold2 : f:('b -> 'a -> 'b) -> init:'b -> 'b
-  end
-#                 class ['a] ilist6 :
-  'a list ->
-  object ('c)
-    val l : 'a list
-    method add : 'a -> 'c
-    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
-    method fold2 : f:('b -> 'a -> 'b) -> init:'b -> 'b
-  end
-#       class virtual ['a] olist :
-  object method virtual fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end
-#         class ['a] onil :
-  object method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end
-#             class ['a] ocons :
-  hd:'a ->
-  tl:'a olist ->
-  object
-    val hd : 'a
-    val tl : 'a olist
-    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
-  end
-#               class ['a] ostream :
-  hd:'a ->
-  tl:'a ostream ->
-  object
-    val hd : 'a
-    val tl : < empty : bool; fold : 'c. f:('a -> 'c -> 'c) -> init:'c -> 'c >
-    method empty : bool
-    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
-  end
-#                   class ['a] ostream1 :
-  hd:'a ->
-  tl:'b ->
-  object ('b)
-    val hd : 'a
-    val tl : 'b
-    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
-    method hd : 'a
-    method tl : 'b
-  end
-#           class vari : object method m : [< `A | `B | `C ] -> int end
-#       class vari : object method m : [< `A | `B | `C ] -> int end
-#           module V : sig type v = [ `A | `B | `C ] val m : [< v ] -> int end
-#         class varj : object method m : [< V.v ] -> int end
-#         module type T =
-  sig class vari : object method m : [< `A | `B | `C ] -> int end end
-#             module M0 :
-  sig class vari : object method m : [< `A | `B | `C ] -> int end end
-#   module M : T
-# val v : M.vari = 
-# - : int = 1
-#               class point :
-  x:int ->
-  y:int -> object val x : int val y : int method x : int method y : int end
-#           class color_point :
-  x:int ->
-  y:int ->
-  color:string ->
-  object
-    val color : string
-    val x : int
-    val y : int
-    method color : string
-    method x : int
-    method y : int
-  end
-#                   class circle :
-  #point ->
-  r:int ->
-  object val p : point val r : int method distance : #point -> float end
-#           val p0 : point = 
-val p1 : point = 
-val cp : color_point = 
-val c : circle = 
-val d : float = 11.
-#   val f : < m : 'a. 'a -> 'a > -> < m : 'b. 'b -> 'b > = 
-#   Characters 41-42:
-  let f (x : < m : 'a. 'a -> 'a list >) = (x : < m : 'b. 'b -> 'c >)
-                                           ^
-Error: This expression has type < m : 'b. 'b -> 'b list >
-       but an expression was expected of type < m : 'b. 'b -> 'c >
-       The universal variable 'b would escape its scope
-#           class id : object method id : 'a -> 'a end
-#         class type id_spec = object method id : 'a -> 'a end
-#       class id_impl : object method id : 'a -> 'a end
-#               class a : object method m : bool end
-and b : object method id : 'a -> 'a end
-#           Characters 72-77:
-    method id x = x
-              ^^^^^
-Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
-#         Characters 75-80:
-    method id x = x
-              ^^^^^
-Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
-#           Characters 80-85:
-    method id _ = x
-              ^^^^^
-Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a
-#                 Characters 92-159:
-  ............x =
-      match r with
-        None -> r <- Some x; x
-      | Some y -> y
-Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a
-#         class c : object method m : 'a -> 'b -> 'a end
-#     val f1 : id -> int * bool = 
-#   val f2 : id -> int * bool = 
-#   Characters 24-28:
-  let f3 f = f#id 1, f#id true
-                          ^^^^
-Error: This expression has type bool but an expression was expected of type
-         int
-#   val f4 : id -> int * bool = 
-#           class c : object method m : #id -> int * bool end
-#             class id2 : object method id : 'a -> 'a method mono : int -> int end
-#   val app : int * bool = (1, true)
-#   Characters 0-25:
-  type 'a foo = 'a foo list
-  ^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: The type abbreviation foo is cyclic
-#     class ['a] bar : 'a -> object  end
-#   type 'a foo = 'a foo bar
-#   - : (< m : 'a. 'a * 'b > as 'b) -> 'c * 'b = 
-# - : (< m : 'a. 'b * 'a list > as 'b) -> 'b * 'c list = 
-# val f :
-  (< m : 'b. 'a * (< n : 'b; .. > as 'b) > as 'a) ->
-  'a * (< n : 'c; .. > as 'c) = 
-# - : (< p : 'b. < m : 'b; n : 'a; .. > as 'b > as 'a) ->
-    (< m : 'c; n : 'a; .. > as 'c)
-= 
-# - : (< m : 'a. 'a * < p : 'b. 'b * 'd * 'c > as 'd > as 'c) ->
-    ('f * < p : 'b. 'b * 'e * 'c > as 'e)
-= 
-#   - : < m : 'a. < p : 'a; .. > as 'b > -> 'b = 
-#   type sum = T of < id : 'a. 'a -> 'a >
-# - : sum -> 'a -> 'a = 
-#   type record = { r : < id : 'a. 'a -> 'a >; }
-# - : record -> 'a -> 'a = 
-# - : record -> 'a -> 'a = 
-#       class myself : object ('b) method self : 'a -> 'b end
-#                       class number :
-  object ('b)
-    val num : int
-    method num : int
-    method prev : 'b
-    method succ : 'b
-    method switch : zero:(unit -> 'a) -> prev:('b -> 'a) -> 'a
-  end
-#     val id : 'a -> 'a = 
-#       class c : object method id : 'a -> 'a end
-#         class c' : object method id : 'a -> 'a end
-#               class d :
-  object
-    val mutable count : int
-    method count : int
-    method id : 'a -> 'a
-    method old : 'a -> 'a
-  end
-#             class ['a] olist :
-  'a list ->
-  object ('c)
-    val l : 'a list
-    method cons : 'a -> 'c
-    method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b
-  end
-#   val sum : int #olist -> int = 
-#   val count : 'a #olist -> int = 
-#     val append : 'a #olist -> ('a #olist as 'b) -> 'b = 
-#     type 'a t = unit
-#   class o : object method x : [> `A ] t -> unit end
-#   class c : object method m : d end
-and d : ?x:int -> unit -> object  end
-# class d : ?x:int -> unit -> object  end
-and c : object method m : d end
-#           class type numeral = object method fold : ('a -> 'a) -> 'a -> 'a end
-class zero : object method fold : ('a -> 'a) -> 'a -> 'a end
-class next : #numeral -> object method fold : ('a -> 'a) -> 'a -> 'a end
-#       class type node_type = object method as_variant : [> `Node of node_type ] end
-#       class node : node_type
-#     class node : object method as_variant : [> `Node of node_type ] end
-#   type bad = { bad : 'a. 'a option ref; }
-# Characters 17-25:
-  let bad = {bad = ref None};;
-                   ^^^^^^^^
-Error: This field value has type 'b option ref which is less general than
-         'a. 'a option ref
-# type bad2 = { mutable bad2 : 'a. 'a option ref option; }
-# val bad2 : bad2 = {bad2 = None}
-# Characters 13-28:
-  bad2.bad2 <- Some (ref None);;
-               ^^^^^^^^^^^^^^^
-Error: This field value has type 'b option ref option
-       which is less general than 'a. 'a option ref option
-#       val f : < m : 'a. < p : 'a * 'c > as 'c > -> 'b -> unit = 
-# val f : < m : 'a. 'a * (< p : int * 'b > as 'b) > -> 'b -> unit = 
-#       type 'a t = [ `A of 'a ]
-#       class c : object method m : ([> 'a t ] as 'a) -> unit end
-#         class c : object method m : ([> 'a t ] as 'a) -> unit end
-#     class c : object method m : ([> 'a t ] as 'a) -> 'a end
-#     class c : object method m : ([> `A ] as 'a) option -> 'a end
-#           Characters 145-166:
-  object method virtual visit : 'a.('a visitor -> 'a) end;;
-                                ^^^^^^^^^^^^^^^^^^^^^
-Error: The universal type variable 'a cannot be generalized:
-       it escapes its scope.
-#                 type ('a, 'b) list_visitor = < caseCons : 'b -> 'b list -> 'a; caseNil : 'a >
-type 'b alist = < visit : 'a. ('a, 'b) list_visitor -> 'a >
-class type ct = object ('a) method fold : ('b -> 'a -> 'b) -> 'b -> 'b end
-type t = { f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b; }
-#     Characters 15-25:
-  type t = u and u = t;;
-  ^^^^^^^^^^
-Error: The type abbreviation t is cyclic
-#       class ['a] a : object constraint 'a = [> `A of 'a a ] end
-type t = [ `A of t a ]
-#     Characters 71-80:
-  type ('a,'b) t constraint 'a = 'b and ('a,'b) u = ('a,'b) t;;
-                                                    ^^^^^^^^^
-Error: Constraints are not satisfied in this type.
-       Type ('a, 'b) t should be an instance of ('c, 'c) t
-#     type 'a t = 'a
-and u = int t
-#     type 'a t constraint 'a = int
-# Characters 26-32:
-  type 'a u = 'a and 'a v = 'a u t;;
-                            ^^^^^^
-Error: Constraints are not satisfied in this type.
-       Type 'a u t should be an instance of int t
-# type 'a u = 'a constraint 'a = int
-and 'a v = 'a u t constraint 'a = int
-#     type g = int
-# type 'a t = unit constraint 'a = g
-# Characters 26-32:
-  type 'a u = 'a and 'a v = 'a u t;;
-                            ^^^^^^
-Error: Constraints are not satisfied in this type.
-       Type 'a u t should be an instance of g t
-# type 'a u = 'a constraint 'a = g
-and 'a v = 'a u t constraint 'a = g
-#     Characters 34-58:
-  type 'a u = < m : 'a v > and 'a v = 'a list u;;
-  ^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In the definition of v, type 'a list u should be 'a u
-#       type 'a t = 'a
-type 'a u = A of 'a t
-#     type 'a t = < a : 'a >
-# - : ('a t as 'a) -> 'a t = 
-# type u = 'a t as 'a
-#       type t = A | B
-# - : [> `A ] * t -> int = 
-# - : [> `A ] * t -> int = 
-# - : [> `A ] option * t -> int = 
-#   - : [> `A ] option * t -> int = 
-# - : t * [< `A | `B ] -> int = 
-# - : [< `A | `B ] * t -> int = 
-# Characters 0-41:
-  function (`A|`B), _ -> 0 | _,(`A|`B) -> 1;;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(`AnyExtraTag, `AnyExtraTag)
-- : [> `A | `B ] * [> `A | `B ] -> int = 
-# Characters 0-29:
-  function `B,1 -> 1 | _,1 -> 2;;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(_, 0)
-Characters 21-24:
-  function `B,1 -> 1 | _,1 -> 2;;
-                       ^^^
-Warning 11: this match case is unused.
-- : [< `B ] * int -> int = 
-# Characters 0-29:
-  function 1,`B -> 1 | 1,_ -> 2;;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(0, _)
-Characters 21-24:
-  function 1,`B -> 1 | 1,_ -> 2;;
-                       ^^^
-Warning 11: this match case is unused.
-- : int * [< `B ] -> int = 
-#       Characters 64-135:
-  type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b]
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Constraints are not satisfied in this type.
-       Type
-       ([> `B of 'a ], 'a) b as 'a
-       should be an instance of
-       (('b, [> `A of 'b ] as 'c) a as 'b, 'c) b
-#     *               class type ['a, 'b] a =
-  object
-    constraint 'a = < as_a : ('a, 'b) a as 'c; b : 'b; .. >
-    constraint 'b = < a : 'a; as_b : ('a, 'b) b; .. >
-    method as_a : 'c
-    method b : 'b
-  end
-and ['a, 'b] b =
-  object
-    constraint 'a = < as_a : ('a, 'b) a; b : 'b; .. >
-    constraint 'b = < a : 'a; as_b : ('a, 'b) b; .. >
-    method a : 'a
-    method as_b : ('a, 'b) b
-  end
-#   class type ['a] ca =
-  object ('b)
-    constraint 'a = < a : 'b; as_b : ('b, 'a) b; .. >
-    method as_a : ('b, 'a) a
-    method b : 'a
-  end
-# class type ['a] cb =
-  object ('b)
-    constraint 'a = < as_a : ('a, 'b) a; b : 'b; .. >
-    method a : 'a
-    method as_b : ('a, 'b) b
-  end
-#     type bt = 'a ca cb as 'a
-#     class c : object method m : int end
-# val f : unit -> c = 
-# val f : unit -> c = 
-# Characters 11-60:
-  let f () = object method private n = 1 method m = {<>}#n end;;
-             ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 15: the following private methods were made public implicitly:
- n.
-val f : unit -> < m : int; n : int > = 
-# Characters 11-56:
-  let f () = object (self:c) method n = 1 method m = 2 end;;
-             ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This object is expected to have type c but actually has type
-         < m : int; n : 'a >
-       The first object type has no method n
-# Characters 11-69:
-  let f () = object (_:'s) constraint 's = < n : int > method m = 1 end;;
-             ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This object is expected to have type < n : int > but actually has type
-         < m : 'a >
-       The second object type has no method n
-#         Characters 66-124:
-      object (self: 's) method x = 3 method private m = self end
-      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This object is expected to have type < x : int; .. >
-       but actually has type < x : int >
-       Self type cannot be unified with a closed object type
-#         val o : < x : int > = 
-#         Characters 76-77:
-    (x :  > as 'bar) >);;
-     ^
-Error: This expression has type < m : 'a. 'a * < m : 'a * 'b > > as 'b
-       but an expression was expected of type
-         < m : 'a. 'a * (< m : 'a * < m : 'c. 'c * 'd > > as 'd) >
-       Types for method m are incompatible
-#         Characters 176-177:
-  let f (x : foo') = (x : bar');;
-                      ^
-Error: This expression has type foo' = < m : 'a. 'a * 'a foo >
-       but an expression was expected of type bar' = < m : 'a. 'a * 'a bar >
-       Type 'a foo = < m : 'a * 'a foo > is not compatible with type
-         'a bar = < m : 'a * < m : 'c. 'c * 'a bar > > 
-       Type 'a foo = < m : 'a * 'a foo > is not compatible with type
-         < m : 'c. 'c * 'a bar > 
-       Types for method m are incompatible
-#     Characters 67-68:
-    (x : )> as 'bar);;
-     ^
-Error: This expression has type
-         < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
-       but an expression was expected of type
-         < m : 'b. 'b * ('b * < m : 'c. 'c * ('c * 'd) >) > as 'd
-       Types for method m are incompatible
-#   Characters 66-67:
-    (x : )> as 'bar);;
-     ^
-Error: This expression has type
-         < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
-       but an expression was expected of type
-         < m : 'b. 'b * ('b * < m : 'c. 'c * ('b * 'd) >) > as 'd
-       Types for method m are incompatible
-#   Characters 51-52:
-    (x :  as 'bar)>);;
-     ^
-Error: This expression has type < m : 'b. 'b * ('b * 'a) > as 'a
-       but an expression was expected of type
-         < m : 'b. 'b * ('b * < m : 'c. 'c * 'd > as 'd) >
-       Types for method m are incompatible
-#     Characters 14-115:
-  ....(x :  ('a *  'bar> as 'bar)>
-         :>  ('a * 'foo)> as 'foo)..
-Error: Type < m : 'a. 'a -> ('a * (< m : 'c. 'c -> 'b as 'e > as 'd) as 'b) >
-       is not a subtype of < m : 'a. 'a -> ('a * 'f as 'h) as 'g > as 'f 
-       Type 'c. 'e is not a subtype of 'a. 'g 
-#       Characters 88-150:
-  = struct let f (x :  as 'foo) = () end;;
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Signature mismatch:
-       ...
-       Values do not match:
-         val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit
-       is not included in
-         val f : < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > -> unit
-#     Characters 78-132:
-  = struct type t =  as 'foo end;;
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Signature mismatch:
-       Modules do not match:
-         sig type t = < m : 'a. 'a * ('a * 'b) > as 'b end
-       is not included in
-         sig type t = < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > end
-       Type declarations do not match:
-         type t = < m : 'a. 'a * ('a * 'b) > as 'b
-       is not included in
-         type t = < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
-#     module M : sig type 'a t type u = < m : 'a. 'a t > end
-#   module M : sig type 'a t val f : < m : 'a. 'a t > -> int end
-#     module M : sig type 'a t val f : < m : 'a. 'a t > -> int end
-#         val f :
-  (< m : 'a. 'a -> (< m : 'a. 'a -> 'c * <  > > as 'c) * < .. >; .. > as 'b) ->
-  'b -> bool = 
-#         type t = [ `A | `B ]
-# type v = private [> t ]
-# - : t -> v = 
-# type u = private [< t ]
-# - : u -> v = 
-# Characters 9-21:
-  fun x -> (x : v :> u);;
-           ^^^^^^^^^^^^
-Error: Type v = [> `A | `B ] is not a subtype of u = [< `A | `B ] 
-# type v = private [< t ]
-# Characters 9-21:
-  fun x -> (x : u :> v);;
-           ^^^^^^^^^^^^
-Error: Type u = [< `A | `B ] is not a subtype of v = [< `A | `B ] 
-# type p = < x : p >
-# type q = private < x : p; .. >
-# - : q -> p = 
-# Characters 9-21:
-  fun x -> (x : p :> q);;
-           ^^^^^^^^^^^^
-Error: Type p = < x : p > is not a subtype of q = < x : p; .. > 
-#       Characters 14-100:
-  ..(x :  as 'a) -> int>
-      :>  as 'b) -> int>)..
-Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of
-         < m : 'b. (< p : int; q : int; .. > as 'b) -> int > 
-       Type < p : int; q : int; .. > as 'c is not a subtype of
-         < p : int; .. > as 'd 
-#     val f2 :
-  < m : 'a. (< p : < a : int >; .. > as 'a) -> int > ->
-  < m : 'b. (< p : < a : int; b : int >; .. > as 'b) -> int > = 
-#     Characters 13-107:
-  ..(x : ;..> as 'a) -> int>
-      :> ;..> as 'b) -> int>)..
-Error: Type < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int >
-       is not a subtype of < m : 'b. (< p : < a : int >; .. > as 'b) -> int > 
-       Type < a : int > is not a subtype of < a : int; b : int > 
-# Characters 11-55:
-  let f4 x = (x : ;..> :> ;..>);;
-             ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Type < p : < a : int; b : int >; .. > is not a subtype of
-         < p : < a : int >; .. > 
-       The second object type has no method b
-#   val f5 :
-  < m : 'a. [< `A of < p : int > ] as 'a > ->
-  < m : 'b. [< `A of <  > ] as 'b > = 
-#   Characters 13-83:
-    (x :  ] as 'a> :>  ] as 'a>);;
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Type < m : 'a. [< `A of <  > ] as 'a > is not a subtype of
-         < m : 'b. [< `A of < p : int > ] as 'b > 
-       Type <  > is not a subtype of < p : int > 
-#     val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > = 
-# - : < m : 'a. 'a -> 'a > -> 'b -> 'b = 
-# val f : < m : 'a. 'a -> 'a > * 'b -> < m : 'a. 'a -> 'a > = 
-# - : < m : 'a. 'a -> 'a > -> 'b -> 'b = 
-# val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > array = 
-# - : < m : 'a. 'a -> 'a > -> 'b -> 'b = 
-#     class c : object method id : 'a -> 'a end
-# type u = c option
-# val just : 'a option -> 'a = 
-# val f : c -> 'a -> 'a = 
-#     val g : c -> 'a -> 'a = 
-#     val h : < id : 'a; .. > -> 'a = 
-#     type 'a u = c option
-# val just : 'a option -> 'a = 
-# val f : c -> 'a -> 'a = 
-#       val f : 'a -> int = 
-val g : 'a -> int = 
-# type 'a t = Leaf of 'a | Node of ('a * 'a) t
-#   val depth : 'a t -> int = 
-#     Characters 34-74:
-    function Leaf _ -> 1 | Node x -> 1 + d x
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This definition has type 'a t -> int which is less general than
-         'a0. 'a0 t -> int
-#   Characters 34-78:
-    function Leaf x -> x | Node x -> 1 + depth x;; (* fails *)
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This definition has type int t -> int which is less general than
-         'a. 'a t -> int
-#   Characters 34-74:
-    function Leaf x -> x | Node x -> depth x;; (* fails *)
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This definition has type 'a t -> 'a which is less general than
-         'a0. 'a0 t -> 'a
-#   Characters 38-78:
-    function Leaf x -> x | Node x -> depth x;; (* fails *)
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This definition has type 'b. 'b t -> 'b which is less general than
-         'a 'b. 'a t -> 'b
-#   val r : 'a list * '_b list ref = ([], {contents = []})
-val q : unit -> 'a list * '_b list ref = 
-# val f : 'a -> 'a = 
-# val zero : [> `B of 'a | `Int of int ] as 'a = `Int 0
-# Characters 39-45:
-  let zero : 'a. [< `Int of int] as 'a = `Int 0;; (* fails *)
-                                         ^^^^^^
-Error: This expression has type [> `Int of int ]
-       but an expression was expected of type [< `Int of int ]
-       Types for tag `Int are incompatible
-#       type t = { f : 'a. [> `B of 'a | `Int of int ] as 'a; }
-val zero : t = {f = `Int 0}
-#   Characters 56-62:
-  let zero = {f = `Int 0} ;; (* fails *)
-                  ^^^^^^
-Error: This expression has type [> `Int of int ]
-       but an expression was expected of type [< `Int of int ]
-       Types for tag `Int are incompatible
-#       val id : 'a -> 'a = 
-val neg : int -> bool -> int * bool = 
-#                         type t = A of int | B of (int * t) list | C of (string * t) list
-val transf : (int -> t) -> t -> t = 
-val transf_alist : (int -> t) -> ('a * t) list -> ('a * t) list = 
-#         type t = { f : 'a. ('a list -> int) Lazy.t; }
-val l : t = {f = }
-#     type t = { f : 'a. 'a -> unit; }
-# - : t = {f = }
-# Characters 19-20:
-  let f ?x y = y in {f};; (* fail *)
-                     ^
-Error: This field value has type unit -> unit which is less general than
-         'a. 'a -> unit
-#               module Polux :
-  sig
-    type 'par t = 'par
-    val ident : 'a -> 'a
-    class alias : object method alias : 'a t -> 'a end
-    val f : < m : 'a. 'a t > -> < m : 'a. 'a >
-  end
-#       Exception: Pervasives.Exit.
-#   Exception: Pervasives.Exit.
-#   Exception: Pervasives.Exit.
-#       Characters 16-44:
-  type 'x t = < f : 'y. 'y t >;;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In the definition of t, type 'y t should be 'x t
-#                   val using_match : bool -> int * ('a -> 'a) = 
-#   - : ('a -> 'a) * ('b -> 'b) = (, )
-# - : ('a -> 'a) * ('b -> 'b) = (, )
-#           val n : < m : 'x 'a. ([< `Foo of 'x ] as 'a) -> 'x > = 
-#     val n : < m : 'x. [< `Foo of 'x ] -> 'x > = 
-#     Characters 59-129:
-    object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;;
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This expression has type < m : 'x. [< `Foo of 'x ] -> 'x >
-       but an expression was expected of type
-         < m : 'a. [< `Foo of int ] -> 'a >
-       The universal variable 'x would escape its scope
-#     Characters 83-153:
-    object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;;
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This expression has type < m : 'x. [< `Foo of 'x ] -> 'x >
-       but an expression was expected of type
-         < m : 'a. [< `Foo of int ] -> 'a >
-       The universal variable 'x would escape its scope
-#         Characters 94-97:
-    if b then x else M.A;;
-                     ^^^
-Error: This expression has type M.t but an expression was expected of type 'x
-       The type constructor M.t would escape its scope
-# 
diff --git a/testsuite/tests/typing-safe-linking/Makefile b/testsuite/tests/typing-safe-linking/Makefile
index a1e8aba8..4e3cf43a 100644
--- a/testsuite/tests/typing-safe-linking/Makefile
+++ b/testsuite/tests/typing-safe-linking/Makefile
@@ -5,7 +5,7 @@ OBJECTS = $(SOURCES:%.ml=%.cmo)
 
 all: a.cmo
 	@printf " ... testing 'b_bad.ml'"
-	@$(OCAMLC) -c -safe-string -warn-error +8 b_bad.ml 2> /dev/null \
+	@$(OCAMLC) $(ADD_COMPFLAGS) -c -safe-string -warn-error +8 b_bad.ml 2> /dev/null \
 	 && echo " => failed" || echo " => passed"
 
 clean:
@@ -13,3 +13,8 @@ clean:
 
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.common
+
+# The second test (`A.y`) is unnecessary, indeed cannot be compiled, under -safe-string
+ifeq ($(SAFE_STRING),true)
+ADD_COMPFLAGS=-pp "sed -e '\$$d'"
+endif
diff --git a/testsuite/tests/typing-safe-linking/a.ml b/testsuite/tests/typing-safe-linking/a.ml
index 6c4ca42e..12e0cb12 100644
--- a/testsuite/tests/typing-safe-linking/a.ml
+++ b/testsuite/tests/typing-safe-linking/a.ml
@@ -2,4 +2,5 @@
      X of string
    | Y : bytes t
 
+(* It is important that the line below is the last line of the file (see Makefile) *)
 let y : string t = Y
diff --git a/testsuite/tests/typing-safe-linking/b_bad.ml b/testsuite/tests/typing-safe-linking/b_bad.ml
index 8730dcbd..6615070a 100644
--- a/testsuite/tests/typing-safe-linking/b_bad.ml
+++ b/testsuite/tests/typing-safe-linking/b_bad.ml
@@ -1,4 +1,5 @@
 let f : string A.t -> unit = function
     A.X s -> print_endline s
 
+(* It is important that the line below is the last line of the file (see Makefile) *)
 let () = f A.y
diff --git a/testsuite/tests/typing-unboxed-types/Makefile b/testsuite/tests/typing-unboxed-types/Makefile
new file mode 100644
index 00000000..9625a3fb
--- /dev/null
+++ b/testsuite/tests/typing-unboxed-types/Makefile
@@ -0,0 +1,3 @@
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-unboxed-types/test.ml b/testsuite/tests/typing-unboxed-types/test.ml
new file mode 100644
index 00000000..f187b76d
--- /dev/null
+++ b/testsuite/tests/typing-unboxed-types/test.ml
@@ -0,0 +1,121 @@
+(* Check the unboxing *)
+
+(* For concrete types *)
+type t1 = A of string [@@ocaml.unboxed];;
+
+let x = A "foo" in
+Obj.repr x == Obj.repr (match x with A s -> s)
+;;
+
+(* For records *)
+type t2 = { f : string } [@@ocaml.unboxed];;
+
+let x = { f = "foo" } in
+Obj.repr x == Obj.repr x.f
+;;
+
+(* For inline records *)
+type t3 = B of { g : string } [@@ocaml.unboxed];;
+
+let x = B { g = "foo" } in
+Obj.repr x == Obj.repr (match x with B {g} -> g)
+;;
+
+(* Check unboxable types *)
+type t4 = C [@@ocaml.unboxed];;  (* no argument *)
+type t5 = D of int * string [@@ocaml.unboxed];; (* more than one argument *)
+type t5 = E | F [@@ocaml.unboxed];;          (* more than one constructor *)
+type t6 = G of int | H [@@ocaml.unboxed];;
+type t7 = I of string | J of bool [@@ocaml.unboxed];;
+
+type t8 = { h : bool; i : int } [@@ocaml.unboxed];;  (* more than one field *)
+type t9 = K of { j : string; l : int } [@@ocaml.unboxed];;
+
+(* let rec must be rejected *)
+type t10 = A of t10 [@@ocaml.unboxed];;
+let rec x = A x;;
+
+(* Representation mismatch between module and signature must be rejected *)
+module M : sig
+  type t = A of string
+end = struct
+  type t = A of string [@@ocaml.unboxed]
+end;;
+
+module N : sig
+  type t = A of string [@@ocaml.unboxed]
+end = struct
+  type t = A of string
+end;;
+
+module O : sig
+  type t = { f : string }
+end = struct
+  type t = { f : string } [@@ocaml.unboxed]
+end;;
+
+module P : sig
+  type t = { f : string } [@@ocaml.unboxed]
+end = struct
+  type t = { f : string }
+end;;
+
+module Q : sig
+  type t = A of { f : string }
+end = struct
+  type t = A of { f : string } [@@ocaml.unboxed]
+end;;
+
+module R : sig
+  type t = A of { f : string } [@@ocaml.unboxed]
+end = struct
+  type t = A of { f : string }
+end;;
+
+
+(* Check interference with representation of float arrays. *)
+type t11 = L of float [@@ocaml.unboxed];;
+let x = Array.make 10 (L 3.14)   (* represented as a flat array *)
+and f (a : t11 array) = a.(0)    (* might wrongly assume an array of pointers *)
+in assert (f x = L 3.14);;
+
+
+(* Check for a potential infinite loop in the typing algorithm. *)
+type 'a t12 = M of 'a t12 [@@ocaml.unboxed];;
+let f (a : int t12 array) = a.(0);;
+
+(* Check for another possible loop *)
+type t13 = A : _ t12 -> t13 [@@ocaml.unboxed];;
+
+
+
+(* should work *)
+type t14;;
+type t15 = A of t14 [@@ocaml.unboxed];;
+
+(* should fail *)
+type 'a abs;;
+type t16 = A : _ abs -> t16 [@@ocaml.unboxed];;
+
+(* should work *)
+type t18 = A : _ list abs -> t18 [@@ocaml.unboxed];;
+
+(* should fail because the compiler knows that t is actually float and
+   optimizes the record's representation *)
+module S : sig
+  type t
+  type u = { f1 : t; f2 : t }
+end = struct
+  type t = A of float [@@ocaml.unboxed]
+  type u = { f1 : t; f2 : t }
+end;;
+
+
+(* implementing [@@immediate] with [@@ocaml.unboxed]: this works because the
+   representation of [t] is [int]
+ *)
+module T : sig
+  type t [@@immediate]
+end = struct
+  type t = A of int [@@ocaml.unboxed]
+end;;
diff --git a/testsuite/tests/typing-unboxed-types/test.ml.reference b/testsuite/tests/typing-unboxed-types/test.ml.reference
new file mode 100644
index 00000000..b555db8d
--- /dev/null
+++ b/testsuite/tests/typing-unboxed-types/test.ml.reference
@@ -0,0 +1,162 @@
+
+#       type t1 = A of string [@@unboxed]
+#       - : bool = true
+#     type t2 = { f : string; } [@@unboxed]
+#       - : bool = true
+#     type t3 = B of { g : string; } [@@unboxed]
+#       - : bool = true
+#     Characters 29-58:
+  type t4 = C [@@ocaml.unboxed];;  (* no argument *)
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because its constructor has no argument.
+# Characters 0-45:
+  type t5 = D of int * string [@@ocaml.unboxed];; (* more than one argument *)
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because
+       its constructor has more than one argument.
+# Characters 0-33:
+  type t5 = E | F [@@ocaml.unboxed];;          (* more than one constructor *)
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because it has more than one constructor.
+# Characters 0-40:
+  type t6 = G of int | H [@@ocaml.unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because it has more than one constructor.
+# Characters 0-51:
+  type t7 = I of string | J of bool [@@ocaml.unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because it has more than one constructor.
+#   Characters 1-50:
+  type t8 = { h : bool; i : int } [@@ocaml.unboxed];;  (* more than one field *)
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because it has more than one field.
+# Characters 0-56:
+  type t9 = K of { j : string; l : int } [@@ocaml.unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because
+       its constructor has more than one argument.
+#     type t10 = A of t10 [@@unboxed]
+# Characters 12-15:
+  let rec x = A x;;
+              ^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#             Characters 121-172:
+  ......struct
+    type t = A of string [@@ocaml.unboxed]
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = A of string [@@unboxed] end
+       is not included in
+         sig type t = A of string end
+       Type declarations do not match:
+         type t = A of string [@@unboxed]
+       is not included in
+         type t = A of string
+       Their internal representations differ:
+       the first declaration uses unboxed representation.
+#           Characters 63-96:
+  ......struct
+    type t = A of string
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = A of string end
+       is not included in
+         sig type t = A of string [@@unboxed] end
+       Type declarations do not match:
+         type t = A of string
+       is not included in
+         type t = A of string [@@unboxed]
+       Their internal representations differ:
+       the second declaration uses unboxed representation.
+#           Characters 48-102:
+  ......struct
+    type t = { f : string } [@@ocaml.unboxed]
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = { f : string; } [@@unboxed] end
+       is not included in
+         sig type t = { f : string; } end
+       Type declarations do not match:
+         type t = { f : string; } [@@unboxed]
+       is not included in
+         type t = { f : string; }
+       Their internal representations differ:
+       the first declaration uses unboxed representation.
+#           Characters 66-102:
+  ......struct
+    type t = { f : string }
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = { f : string; } end
+       is not included in
+         sig type t = { f : string; } [@@unboxed] end
+       Type declarations do not match:
+         type t = { f : string; }
+       is not included in
+         type t = { f : string; } [@@unboxed]
+       Their internal representations differ:
+       the second declaration uses unboxed representation.
+#           Characters 53-112:
+  ......struct
+    type t = A of { f : string } [@@ocaml.unboxed]
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = A of { f : string; } [@@unboxed] end
+       is not included in
+         sig type t = A of { f : string; } end
+       Type declarations do not match:
+         type t = A of { f : string; } [@@unboxed]
+       is not included in
+         type t = A of { f : string; }
+       Their internal representations differ:
+       the first declaration uses unboxed representation.
+#           Characters 71-112:
+  ......struct
+    type t = A of { f : string }
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = A of { f : string; } end
+       is not included in
+         sig type t = A of { f : string; } [@@unboxed] end
+       Type declarations do not match:
+         type t = A of { f : string; }
+       is not included in
+         type t = A of { f : string; } [@@unboxed]
+       Their internal representations differ:
+       the second declaration uses unboxed representation.
+#       type t11 = L of float [@@unboxed]
+#     - : unit = ()
+#       type 'a t12 = M of 'a t12 [@@unboxed]
+# val f : int t12 array -> int t12 = 
+#     type t13 = A : 'a t12 -> t13 [@@unboxed]
+#         type t14
+# type t15 = A of t14 [@@unboxed]
+#     type 'a abs
+# Characters 0-45:
+  type t16 = A : _ abs -> t16 [@@ocaml.unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because
+       it might contain both float and non-float values.
+       You should annotate it with [@@ocaml.boxed].
+#     type t18 = A : 'a list abs -> t18 [@@unboxed]
+#   *               Characters 176-256:
+  ......struct
+    type t = A of float [@@ocaml.unboxed]
+    type u = { f1 : t; f2 : t }
+  end..
+Error: Signature mismatch:
+       ...
+       Type declarations do not match:
+         type u = { f1 : t; f2 : t; }
+       is not included in
+         type u = { f1 : t; f2 : t; }
+       Their internal representations differ:
+       the first declaration uses unboxed float representation.
+#     * *           module T : sig type t [@@immediate] end
+# 
diff --git a/testsuite/tests/typing-warnings/Makefile b/testsuite/tests/typing-warnings/Makefile
index fd7f751c..646c8d49 100644
--- a/testsuite/tests/typing-warnings/Makefile
+++ b/testsuite/tests/typing-warnings/Makefile
@@ -16,4 +16,4 @@
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.toplevel
 include $(BASEDIR)/makefiles/Makefile.common
-TOPFLAGS = -w A
+TOPFLAGS = -w A -strict-sequence
diff --git a/testsuite/tests/typing-warnings/exhaustiveness.ml b/testsuite/tests/typing-warnings/exhaustiveness.ml
index 2ddb79d3..d3d9bc05 100644
--- a/testsuite/tests/typing-warnings/exhaustiveness.ml
+++ b/testsuite/tests/typing-warnings/exhaustiveness.ml
@@ -32,7 +32,8 @@ type 'a pair = {left: 'a; right: 'a};;
 
 let f : (int t box pair * bool) option -> unit = function None -> ();;
 let f : (string t box pair * bool) option -> unit = function None -> ();;
-
+let f = function {left=Box 0; _ } -> ();;
+let f = function {left=Box 0;right=Box 1} -> ();;
 
 (* Examples from ML2015 paper *)
 
diff --git a/testsuite/tests/typing-warnings/exhaustiveness.ml.reference b/testsuite/tests/typing-warnings/exhaustiveness.ml.reference
index e19efbb0..4935f690 100644
--- a/testsuite/tests/typing-warnings/exhaustiveness.ml.reference
+++ b/testsuite/tests/typing-warnings/exhaustiveness.ml.reference
@@ -4,7 +4,7 @@
       None, None -> 1
     | Some _, Some _ -> 2..
 Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
+Here is an example of a case that is not matched:
 ((Some _, None)|(None, Some _))
 val f : 'a option * 'b option -> int = 
 #             type _ t = A : int t | B : bool t | C : char t | D : float t
@@ -14,7 +14,7 @@ type v = E | F | G
   .function A, A, A, A, A, A, A, _, U, U -> 1
      | _, _, _, _, _, _, _, G, _, _ -> 1
 Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
+Here is an example of a case that is not matched:
 (A, A, A, A, A, A, B, (E|F), _, _)
 Characters 172-200:
      | _, _, _, _, _, _, _, G, _, _ -> 1
@@ -52,7 +52,7 @@ val f : unit t option -> int = 
   let f (x : int t option) = match x with None -> 1;; (* warn *)
                              ^^^^^^^^^^^^^^^^^^^^^^
 Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
+Here is an example of a case that is not matched:
 Some A
 val f : int t option -> int = 
 #         type 'a box = Box of 'a
@@ -61,11 +61,25 @@ type 'a pair = { left : 'a; right : 'a; }
   let f : (int t box pair * bool) option -> unit = function None -> ();;
                                                    ^^^^^^^^^^^^^^^^^^^
 Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
+Here is an example of a case that is not matched:
 Some ({left=Box A; right=Box A}, _)
 val f : (int t box pair * bool) option -> unit = 
 # val f : (string t box pair * bool) option -> unit = 
-#               type _ t = Int : int t | Bool : bool t
+# Characters 8-39:
+  let f = function {left=Box 0; _ } -> ();;
+          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+{left=Box 1; _ }
+val f : int box pair -> unit = 
+# Characters 8-47:
+  let f = function {left=Box 0;right=Box 1} -> ();;
+          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+{left=Box 0; right=Box 0}
+val f : int box pair -> unit = 
+#             type _ t = Int : int t | Bool : bool t
 #         val f : 'a t -> 'a = 
 #     val g : int t -> int = 
 #         val h : 'a t -> 'a t -> bool = 
@@ -75,7 +89,7 @@ module A : sig type a type b val eq : (a, b) cmp end
   let f : (A.a, A.b) cmp -> unit = function Any -> ()
                                    ^^^^^^^^^^^^^^^^^^
 Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
+Here is an example of a case that is not matched:
 Eq
 val f : (A.a, A.b) cmp -> unit = 
 #     val deep : char t option -> char = 
@@ -90,7 +104,7 @@ type _ succ = Succ
     function None -> false
     ^^^^^^^^^^^^^^^^^^^^^^
 Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
+Here is an example of a case that is not matched:
 Some (PlusS _)
 val harder : (zero succ, zero succ, zero succ) plus option -> bool = 
 #     val harder : (zero succ, zero succ, zero succ) plus option -> bool = 
diff --git a/testsuite/tests/typing-warnings/pr5892.ml.reference b/testsuite/tests/typing-warnings/pr5892.ml.reference
index 1321634a..e56687af 100644
--- a/testsuite/tests/typing-warnings/pr5892.ml.reference
+++ b/testsuite/tests/typing-warnings/pr5892.ml.reference
@@ -6,7 +6,7 @@
   let f : label choice -> bool = function Left -> true;; (* warn *)
                                  ^^^^^^^^^^^^^^^^^^^^^
 Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
+Here is an example of a case that is not matched:
 Right
 val f : CamlinternalOO.label choice -> bool = 
 # 
diff --git a/testsuite/tests/typing-warnings/pr6872.ml.principal.reference b/testsuite/tests/typing-warnings/pr6872.ml.principal.reference
index 097e34f9..eaebf225 100644
--- a/testsuite/tests/typing-warnings/pr6872.ml.principal.reference
+++ b/testsuite/tests/typing-warnings/pr6872.ml.principal.reference
@@ -10,7 +10,8 @@ The first one was selected. Please disambiguate if this is wrong.
 # Characters 6-7:
   raise A;;
         ^
-Warning 42: this use of A required disambiguation.
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Exception: A.
 # - : a -> unit = 
 # Characters 26-27:
@@ -26,10 +27,12 @@ Error: This pattern matches values of type a
 # Characters 10-11:
   try raise A with A -> 2;;
             ^
-Warning 42: this use of A required disambiguation.
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 17-18:
   try raise A with A -> 2;;
                    ^
-Warning 42: this use of A required disambiguation.
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 - : int = 2
 # 
diff --git a/testsuite/tests/typing-warnings/pr6872.ml.reference b/testsuite/tests/typing-warnings/pr6872.ml.reference
index 072ccb4d..7c0b3503 100644
--- a/testsuite/tests/typing-warnings/pr6872.ml.reference
+++ b/testsuite/tests/typing-warnings/pr6872.ml.reference
@@ -10,21 +10,25 @@ The first one was selected. Please disambiguate if this is wrong.
 # Characters 6-7:
   raise A;;
         ^
-Warning 42: this use of A required disambiguation.
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Exception: A.
 # - : a -> unit = 
 # Characters 26-27:
   function Not_found -> 1 | A -> 2 | _ -> 3;;
                             ^
-Warning 42: this use of A required disambiguation.
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 - : exn -> int = 
 # Characters 10-11:
   try raise A with A -> 2;;
             ^
-Warning 42: this use of A required disambiguation.
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 17-18:
   try raise A with A -> 2;;
                    ^
-Warning 42: this use of A required disambiguation.
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 - : int = 2
 # 
diff --git a/testsuite/tests/typing-warnings/pr7085.ml.reference b/testsuite/tests/typing-warnings/pr7085.ml.reference
index 960ccaff..3a54d4ad 100644
--- a/testsuite/tests/typing-warnings/pr7085.ml.reference
+++ b/testsuite/tests/typing-warnings/pr7085.ml.reference
@@ -3,7 +3,7 @@
        match M.is_t () with None -> 0
        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
+Here is an example of a case that is not matched:
 Some (Is Eq)
 module TypEq : sig type (_, _) t = Eq : ('a, 'a) t end
 module type T =
diff --git a/testsuite/tests/typing-warnings/pr7297.ml b/testsuite/tests/typing-warnings/pr7297.ml
new file mode 100644
index 00000000..64b6fd5a
--- /dev/null
+++ b/testsuite/tests/typing-warnings/pr7297.ml
@@ -0,0 +1 @@
+let () = raise Exit; () ;; (* warn *)
diff --git a/testsuite/tests/typing-warnings/pr7297.ml.reference b/testsuite/tests/typing-warnings/pr7297.ml.reference
new file mode 100644
index 00000000..9c9dbdd0
--- /dev/null
+++ b/testsuite/tests/typing-warnings/pr7297.ml.reference
@@ -0,0 +1,7 @@
+
+# Characters 9-19:
+  let () = raise Exit; () ;; (* warn *)
+           ^^^^^^^^^^
+Warning 21: this statement never returns (or has an unsound type.)
+Exception: Pervasives.Exit.
+# 
diff --git a/testsuite/tests/typing-warnings/records.ml.principal.reference b/testsuite/tests/typing-warnings/records.ml.principal.reference
index c208dee2..989fce35 100644
--- a/testsuite/tests/typing-warnings/records.ml.principal.reference
+++ b/testsuite/tests/typing-warnings/records.ml.principal.reference
@@ -4,7 +4,8 @@
 #                 Characters 49-50:
     let f1 (r:t) = r.x (* ok *)
                      ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 89-90:
     let f2 r = ignore (r:t); r.x (* non principal *)
                                ^
@@ -12,15 +13,18 @@ Warning 18: this type-based field disambiguation is not principal.
 Characters 89-90:
     let f2 r = ignore (r:t); r.x (* non principal *)
                                ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 148-149:
       match r with {x; y} -> y + y (* ok *)
                     ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 151-152:
       match r with {x; y} -> y + y (* ok *)
                        ^
-Warning 42: this use of y required disambiguation.
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 148-149:
       match r with {x; y} -> y + y (* ok *)
                     ^
@@ -51,7 +55,8 @@ Error: This pattern matches values of type M1.u
 # Characters 18-21:
   let f (r:M.t) = r.M.x;; (* ok *)
                     ^^^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 val f : M.t -> int = 
 # Characters 18-19:
   let f (r:M.t) = r.x;; (* warning *)
@@ -62,12 +67,14 @@ be selected if the type becomes unknown.
 Characters 18-19:
   let f (r:M.t) = r.x;; (* warning *)
                     ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 val f : M.t -> int = 
 # Characters 8-9:
   let f ({x}:M.t) = x;; (* warning *)
           ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 7-10:
   let f ({x}:M.t) = x;; (* warning *)
          ^^^
@@ -80,7 +87,8 @@ val f : M.t -> int = 
 #         Characters 57-58:
     let f (r:M.t) = r.x
                       ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 30-36:
     open N
     ^^^^^^
@@ -101,7 +109,8 @@ module OK : sig val f : M.t -> int end
 #       Characters 37-38:
     let f {x;z} = x,z
            ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 36-41:
     let f {x;z} = x,z
           ^^^^^
@@ -116,11 +125,13 @@ Error: Some record fields are undefined: y
 #           Characters 90-91:
     let r = {x=3; y=true}
              ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 95-96:
     let r = {x=3; y=true}
                   ^
-Warning 42: this use of y required disambiguation.
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 module OK :
   sig
     type u = { x : int; y : bool; }
@@ -172,7 +183,8 @@ Error: The record field NM.y belongs to the type NM.foo = M.foo
 #       Characters 65-66:
     let f r = ignore (r: foo); {r with x = 2; z = 3}
                                        ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 72-73:
     let f r = ignore (r: foo); {r with x = 2; z = 3}
                                               ^
@@ -187,7 +199,8 @@ Error: This record expression is expected to have type M.foo
 #       Characters 66-67:
     let f r = ignore (r: foo); { r with x = 3; a = 4 }
                                         ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 73-74:
     let f r = ignore (r: foo); { r with x = 3; a = 4 }
                                                ^
@@ -196,11 +209,13 @@ Error: This record expression is expected to have type M.foo
 #         Characters 39-40:
     let r = {x=1; y=2}
              ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 44-45:
     let r = {x=1; y=2}
                   ^
-Warning 42: this use of y required disambiguation.
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 67-68:
     let r: other = {x=1; y=2}
                     ^
@@ -225,13 +240,15 @@ class f : t -> object  end
 # Characters 12-13:
   class g = f A;; (* ok *)
               ^
-Warning 42: this use of A required disambiguation.
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 class g : f
 #   class f : 'a -> 'a -> object  end
 # Characters 13-14:
   class g = f (A : t) A;; (* warn with -principal *)
                ^
-Warning 42: this use of A required disambiguation.
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 20-21:
   class g = f (A : t) A;; (* warn with -principal *)
                       ^
@@ -239,12 +256,14 @@ Warning 18: this type-based constructor disambiguation is not principal.
 Characters 20-21:
   class g = f (A : t) A;; (* warn with -principal *)
                       ^
-Warning 42: this use of A required disambiguation.
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 class g : f
 #                       Characters 199-200:
     let y : t = {x = 0}
                  ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 114-120:
     open M  (* this open is unused, it isn't reported as shadowing 'x' *)
     ^^^^^^
@@ -273,7 +292,8 @@ module Shadow2 :
 #                 Characters 167-170:
     let f (u : u) = match u with `Key {loc} -> loc
                                        ^^^
-Warning 42: this use of loc required disambiguation.
+Warning 42: this use of loc relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 module P6235 :
   sig
     type t = { loc : string; }
diff --git a/testsuite/tests/typing-warnings/records.ml.reference b/testsuite/tests/typing-warnings/records.ml.reference
index 2853439c..349721e6 100644
--- a/testsuite/tests/typing-warnings/records.ml.reference
+++ b/testsuite/tests/typing-warnings/records.ml.reference
@@ -4,19 +4,23 @@
 #                 Characters 49-50:
     let f1 (r:t) = r.x (* ok *)
                      ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 89-90:
     let f2 r = ignore (r:t); r.x (* non principal *)
                                ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 148-149:
       match r with {x; y} -> y + y (* ok *)
                     ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 151-152:
       match r with {x; y} -> y + y (* ok *)
                        ^
-Warning 42: this use of y required disambiguation.
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 148-149:
       match r with {x; y} -> y + y (* ok *)
                     ^
@@ -36,11 +40,13 @@ Error: This expression has type bool but an expression was expected of type
 #               Characters 86-87:
          {x; y} -> y + y
           ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 89-90:
          {x; y} -> y + y
              ^
-Warning 42: this use of y required disambiguation.
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 86-87:
          {x; y} -> y + y
           ^
@@ -50,7 +56,8 @@ module F2 : sig val f : M1.t -> int end
 # Characters 18-21:
   let f (r:M.t) = r.M.x;; (* ok *)
                     ^^^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 val f : M.t -> int = 
 # Characters 18-19:
   let f (r:M.t) = r.x;; (* warning *)
@@ -61,12 +68,14 @@ be selected if the type becomes unknown.
 Characters 18-19:
   let f (r:M.t) = r.x;; (* warning *)
                     ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 val f : M.t -> int = 
 # Characters 8-9:
   let f ({x}:M.t) = x;; (* warning *)
           ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 7-10:
   let f ({x}:M.t) = x;; (* warning *)
          ^^^
@@ -79,7 +88,8 @@ val f : M.t -> int = 
 #         Characters 57-58:
     let f (r:M.t) = r.x
                       ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 30-36:
     open N
     ^^^^^^
@@ -100,7 +110,8 @@ module OK : sig val f : M.t -> int end
 #       Characters 37-38:
     let f {x;z} = x,z
            ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 36-41:
     let f {x;z} = x,z
           ^^^^^
@@ -115,11 +126,13 @@ Error: Some record fields are undefined: y
 #           Characters 90-91:
     let r = {x=3; y=true}
              ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 95-96:
     let r = {x=3; y=true}
                   ^
-Warning 42: this use of y required disambiguation.
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 module OK :
   sig
     type u = { x : int; y : bool; }
@@ -171,7 +184,8 @@ Error: The record field NM.y belongs to the type NM.foo = M.foo
 #       Characters 65-66:
     let f r = ignore (r: foo); {r with x = 2; z = 3}
                                        ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 72-73:
     let f r = ignore (r: foo); {r with x = 2; z = 3}
                                               ^
@@ -186,7 +200,8 @@ Error: This record expression is expected to have type M.foo
 #       Characters 66-67:
     let f r = ignore (r: foo); { r with x = 3; a = 4 }
                                         ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 73-74:
     let f r = ignore (r: foo); { r with x = 3; a = 4 }
                                                ^
@@ -195,11 +210,13 @@ Error: This record expression is expected to have type M.foo
 #         Characters 39-40:
     let r = {x=1; y=2}
              ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 44-45:
     let r = {x=1; y=2}
                   ^
-Warning 42: this use of y required disambiguation.
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 67-68:
     let r: other = {x=1; y=2}
                     ^
@@ -224,22 +241,26 @@ class f : t -> object  end
 # Characters 12-13:
   class g = f A;; (* ok *)
               ^
-Warning 42: this use of A required disambiguation.
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 class g : f
 #   class f : 'a -> 'a -> object  end
 # Characters 13-14:
   class g = f (A : t) A;; (* warn with -principal *)
                ^
-Warning 42: this use of A required disambiguation.
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 20-21:
   class g = f (A : t) A;; (* warn with -principal *)
                       ^
-Warning 42: this use of A required disambiguation.
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 class g : f
 #                       Characters 199-200:
     let y : t = {x = 0}
                  ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 114-120:
     open M  (* this open is unused, it isn't reported as shadowing 'x' *)
     ^^^^^^
@@ -268,7 +289,8 @@ module Shadow2 :
 #                 Characters 167-170:
     let f (u : u) = match u with `Key {loc} -> loc
                                        ^^^
-Warning 42: this use of loc required disambiguation.
+Warning 42: this use of loc relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 module P6235 :
   sig
     type t = { loc : string; }
@@ -279,7 +301,8 @@ module P6235 :
 #                     Characters 220-223:
       |`Key {loc} -> loc
              ^^^
-Warning 42: this use of loc required disambiguation.
+Warning 42: this use of loc relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 module P6235' :
   sig
     type t = { loc : string; }
diff --git a/testsuite/tests/typing-warnings/unused_types.ml b/testsuite/tests/typing-warnings/unused_types.ml
index afe7d4cf..a8333abb 100644
--- a/testsuite/tests/typing-warnings/unused_types.ml
+++ b/testsuite/tests/typing-warnings/unused_types.ml
@@ -16,3 +16,55 @@ end = struct
   type unused = A of unused
 end
 ;;
+
+module Unused_exception : sig
+end = struct
+  exception Nobody_uses_me
+end
+;;
+
+module Unused_extension_constructor : sig
+  type t = ..
+end = struct
+  type t = ..
+  type t += Nobody_uses_me
+end
+;;
+
+module Unused_exception_outside_patterns : sig
+  val falsity : exn -> bool
+end = struct
+  exception Nobody_constructs_me
+  let falsity = function
+    | Nobody_constructs_me -> true
+    | _ -> false
+end
+;;
+
+module Unused_extension_outside_patterns : sig
+  type t = ..
+  val falsity : t -> bool
+end = struct
+  type t = ..
+  type t += Nobody_constructs_me
+  let falsity = function
+    | Nobody_constructs_me -> true
+    | _ -> false
+end
+;;
+
+module Unused_private_exception : sig
+  type exn += private Private_exn
+end = struct
+  exception Private_exn
+end
+;;
+
+module Unused_private_extension : sig
+  type t = ..
+  type t += private Private_ext
+end = struct
+  type t = ..
+  type t += Private_ext
+end
+;;
diff --git a/testsuite/tests/typing-warnings/unused_types.ml.reference b/testsuite/tests/typing-warnings/unused_types.ml.reference
index d515c24e..9451ee69 100644
--- a/testsuite/tests/typing-warnings/unused_types.ml.reference
+++ b/testsuite/tests/typing-warnings/unused_types.ml.reference
@@ -18,4 +18,40 @@ Characters 40-65:
     ^^^^^^^^^^^^^^^^^^^^^^^^^
 Warning 37: unused constructor A.
 module Unused_rec : sig  end
+#           Characters 46-70:
+    exception Nobody_uses_me
+    ^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 38: unused exception Nobody_uses_me
+module Unused_exception : sig  end
+#               Characters 96-110:
+    type t += Nobody_uses_me
+              ^^^^^^^^^^^^^^
+Warning 38: unused extension constructor Nobody_uses_me
+module Unused_extension_constructor : sig type t = .. end
+#                   Characters 91-121:
+    exception Nobody_constructs_me
+    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 38: exception Nobody_constructs_me is never used to build values.
+(However, this constructor appears in patterns.)
+module Unused_exception_outside_patterns : sig val falsity : exn -> bool end
+#                       Characters 127-147:
+    type t += Nobody_constructs_me
+              ^^^^^^^^^^^^^^^^^^^^
+Warning 38: extension constructor Nobody_constructs_me is never used to build values.
+(However, this constructor appears in patterns.)
+module Unused_extension_outside_patterns :
+  sig type t = .. val falsity : t -> bool end
+#             Characters 88-109:
+    exception Private_exn
+    ^^^^^^^^^^^^^^^^^^^^^
+Warning 38: exception Private_exn is never used to build values.
+It is exported or rebound as a private extension.
+module Unused_private_exception : sig type exn += private Private_exn end
+#                 Characters 124-135:
+    type t += Private_ext
+              ^^^^^^^^^^^
+Warning 38: extension constructor Private_ext is never used to build values.
+It is exported or rebound as a private extension.
+module Unused_private_extension :
+  sig type t = .. type t += private Private_ext end
 # 
diff --git a/testsuite/tests/unboxed-primitive-args/common.ml b/testsuite/tests/unboxed-primitive-args/common.ml
index 53ffe758..d1f13d34 100644
--- a/testsuite/tests/unboxed-primitive-args/common.ml
+++ b/testsuite/tests/unboxed-primitive-args/common.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                  Jeremie Dimino, Jane Street Europe                    *)
-(*                                                                        *)
-(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open StdLabels
 
 open Bigarray
diff --git a/testsuite/tests/unboxed-primitive-args/common.mli b/testsuite/tests/unboxed-primitive-args/common.mli
index 4f31d84d..b7459bb1 100644
--- a/testsuite/tests/unboxed-primitive-args/common.mli
+++ b/testsuite/tests/unboxed-primitive-args/common.mli
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                  Jeremie Dimino, Jane Street Europe                    *)
-(*                                                                        *)
-(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (** Type of arguments/result *)
 type 'a typ =
   | Int       : int       typ
diff --git a/testsuite/tests/unboxed-primitive-args/gen_test.ml b/testsuite/tests/unboxed-primitive-args/gen_test.ml
index 65de0e7b..8f4b2dfe 100644
--- a/testsuite/tests/unboxed-primitive-args/gen_test.ml
+++ b/testsuite/tests/unboxed-primitive-args/gen_test.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                  Jeremie Dimino, Jane Street Europe                    *)
-(*                                                                        *)
-(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* This programs generate stubs with various prototype combinations *)
 
 open StdLabels
diff --git a/testsuite/tests/unwind/Makefile b/testsuite/tests/unwind/Makefile
index bd26bc65..18b39ea3 100644
--- a/testsuite/tests/unwind/Makefile
+++ b/testsuite/tests/unwind/Makefile
@@ -13,9 +13,11 @@ default:
 	  LD="`echo $$LDFULL | grep -o \"ld64-[0-9]*\"`"; \
 	  LDVER="`echo $$LD | sed \"s/ld64-//\"`"; \
 	  if [[ -z "$$LD" ]]; then \
-	    echo " => skipped (ld64-[0-9]* not found in 'ld -v' output)"; \
+	    echo " => skipped (unknown linker: pattern ld64-[0-9]* not found" \
+	    echo "    in 'ld -v' output)"; \
 	  elif [[ $$LDVER -lt 224 ]]; then \
-	   echo " => skipped (ld version is $$LDVER < 224)"; \
+	   echo " => skipped (ld version is $$LDVER, only 224 or above " \
+	   echo "    are supported)"; \
 	  else \
 	    $(MAKE) native_macosx_tests; \
 	  fi; \
diff --git a/testsuite/tests/warnings/w01.reference b/testsuite/tests/warnings/w01.reference
index 492ec7dc..5221256f 100644
--- a/testsuite/tests/warnings/w01.reference
+++ b/testsuite/tests/warnings/w01.reference
@@ -5,7 +5,7 @@ Warning 5: this function application is partial,
 maybe some arguments are missing.
 File "w01.ml", line 20, characters 4-5:
 Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
+Here is an example of a case that is not matched:
 0
 File "w01.ml", line 25, characters 0-1:
 Warning 10: this expression should have type unit.
diff --git a/testsuite/tests/warnings/w50.ml b/testsuite/tests/warnings/w50.ml
new file mode 100755
index 00000000..14877bbe
--- /dev/null
+++ b/testsuite/tests/warnings/w50.ml
@@ -0,0 +1,7 @@
+module A : sig end = struct
+  module L = List
+
+  module X1 = struct end
+
+  module Y1 = X1
+end
diff --git a/testsuite/tests/warnings/w50.reference b/testsuite/tests/warnings/w50.reference
new file mode 100644
index 00000000..db08d0aa
--- /dev/null
+++ b/testsuite/tests/warnings/w50.reference
@@ -0,0 +1,4 @@
+File "w50.ml", line 2, characters 2-17:
+Warning 60: unused module L.
+File "w50.ml", line 6, characters 2-16:
+Warning 60: unused module Y1.
diff --git a/testsuite/tests/warnings/w59.opt_backend.clambda.opt_reference b/testsuite/tests/warnings/w59.opt_backend.clambda.opt_reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/warnings/w59.opt_backend.flambda.opt_reference b/testsuite/tests/warnings/w59.opt_backend.flambda.opt_reference
new file mode 100644
index 00000000..a7e8b93c
--- /dev/null
+++ b/testsuite/tests/warnings/w59.opt_backend.flambda.opt_reference
@@ -0,0 +1,44 @@
+File "w59.opt_backend.ml", line 25, characters 2-43:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
+File "w59.opt_backend.ml", line 26, characters 2-43:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
+File "w59.opt_backend.ml", line 27, characters 2-43:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
+File "w59.opt_backend.ml", line 28, characters 2-43:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
+File "w59.opt_backend.ml", line 35, characters 2-7:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
+File "w59.opt_backend.ml", line 35, characters 2-7:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
+File "w59.opt_backend.ml", line 25, characters 2-43:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
+File "w59.opt_backend.ml", line 26, characters 2-43:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
+File "w59.opt_backend.ml", line 27, characters 2-43:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
+File "w59.opt_backend.ml", line 28, characters 2-43:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
+File "w59.opt_backend.ml", line 35, characters 2-7:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
diff --git a/testsuite/tests/warnings/w59.opt_backend.ml b/testsuite/tests/warnings/w59.opt_backend.ml
new file mode 100644
index 00000000..91e51474
--- /dev/null
+++ b/testsuite/tests/warnings/w59.opt_backend.ml
@@ -0,0 +1,44 @@
+
+(* Check that the warning 59 (assignment to immutable value) does not
+   trigger on those examples *)
+let a = Lazy.force (lazy "a")
+let b = Lazy.force (lazy 1)
+let c = Lazy.force (lazy 3.14)
+let d = Lazy.force (lazy 'a')
+let e = Lazy.force (lazy (fun x -> x+1))
+let rec f (x:int) : int = g x and g x = f x
+let h = Lazy.force (lazy f)
+let i = Lazy.force (lazy g)
+let j = Lazy.force (lazy 1L)
+let k = Lazy.force (lazy (1,2))
+let l = Lazy.force (lazy [|3.14|])
+let m = Lazy.force (lazy (Sys.opaque_identity 3.14))
+let n = Lazy.force (lazy None)
+
+(* Check that obviously wrong code is reported *)
+let o = (1,2)
+let p = fun x -> x
+let q = 3.14
+let r = 1
+
+let () =
+  Obj.set_field (Obj.repr o) 0 (Obj.repr 3);
+  Obj.set_field (Obj.repr p) 0 (Obj.repr 3);
+  Obj.set_field (Obj.repr q) 0 (Obj.repr 3);
+  Obj.set_field (Obj.repr r) 0 (Obj.repr 3)
+
+let set v =
+  Obj.set_field (Obj.repr v) 0 (Obj.repr 3)
+  [@@inline]
+
+let () =
+  set o
+
+(* Sys.opaque_identity hide all information and shouldn't warn *)
+
+let opaque = Sys.opaque_identity (1,2)
+let set_opaque =
+  Obj.set_field
+    (Obj.repr opaque)
+    0
+    (Obj.repr 3)
diff --git a/testsuite/tests/warnings/w59.opt_backend.reference b/testsuite/tests/warnings/w59.opt_backend.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tools/Makefile b/testsuite/tools/Makefile
new file mode 100644
index 00000000..8c9dd05a
--- /dev/null
+++ b/testsuite/tools/Makefile
@@ -0,0 +1,31 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                 Jeremie Dimino, Jane Street Europe                     *
+#*                                                                        *
+#*   Copyright 2016 Jane Street Group LLC                                 *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed 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=..
+MAIN=expect_test
+PROG=$(MAIN)$(EXE)
+COMPFLAGS=-I $(OTOPDIR)/parsing -I $(OTOPDIR)/utils \
+          -I $(OTOPDIR)/driver -I $(OTOPDIR)/toplevel
+LIBRARIES=../../compilerlibs/ocamlcommon \
+          ../../compilerlibs/ocamlbytecomp \
+          ../../compilerlibs/ocamltoplevel
+
+$(PROG): $(MAIN).cmo
+	$(OCAMLC) -linkall -o $(PROG) $(LIBRARIES:=.cma) $(MAIN).cmo
+
+include $(BASEDIR)/makefiles/Makefile.common
+
+.PHONY: clean
+clean: defaultclean
+	rm -f $(PROG)
diff --git a/testsuite/tools/expect_test.ml b/testsuite/tools/expect_test.ml
new file mode 100644
index 00000000..6ddd44ba
--- /dev/null
+++ b/testsuite/tools/expect_test.ml
@@ -0,0 +1,366 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Jeremie Dimino, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2016 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Execute a list of phrases from a .ml file and compare the result to the
+   expected output, written inside [%%expect ...] nodes. At the end, create
+   a .corrected file containing the corrected expectations. The test is
+   successful if there is no differences between the two files.
+
+   An [%%expect] node always contains both the expected outcome with and
+   without -principal. When the two differ the expectation is written as
+   follows:
+
+   {[
+     [%%expect {|
+     output without -principal
+     |}, Principal{|
+     output with -principal
+     |}]
+   ]}
+*)
+
+[@@@ocaml.warning "-40"]
+
+open StdLabels
+
+(* representation of: {tag|str|tag} *)
+type string_constant =
+  { str : string
+  ; tag : string
+  }
+
+type expectation =
+  { extid_loc   : Location.t (* Location of "expect" in "[%%expect ...]" *)
+  ; payload_loc : Location.t (* Location of the whole payload *)
+  ; normal      : string_constant (* expectation without -principal *)
+  ; principal   : string_constant (* expectation with -principal *)
+  }
+
+(* A list of phrases with the expected toplevel output *)
+type chunk =
+  { phrases     : Parsetree.toplevel_phrase list
+  ; expectation : expectation
+  }
+
+type correction =
+  { corrected_expectations : expectation list
+  ; trailing_output        : string
+  }
+
+let match_expect_extension (ext : Parsetree.extension) =
+  match ext with
+  | ({Asttypes.txt="expect"|"ocaml.expect"; loc = extid_loc}, payload) ->
+    let invalid_payload () =
+      Location.raise_errorf ~loc:extid_loc
+        "invalid [%%%%expect payload]"
+    in
+    let string_constant (e : Parsetree.expression) =
+      match e.pexp_desc with
+      | Pexp_constant (Pconst_string (str, Some tag)) ->
+        { str; tag }
+      | _ -> invalid_payload ()
+    in
+    let expectation =
+      match payload with
+      | PStr [{ pstr_desc = Pstr_eval (e, []) }] ->
+        let normal, principal =
+          match e.pexp_desc with
+          | Pexp_tuple
+              [ a
+              ; { pexp_desc = Pexp_construct
+                                ({ txt = Lident "Principal"; _ }, Some b) }
+              ] ->
+            (string_constant a, string_constant b)
+          | _ -> let s = string_constant e in (s, s)
+        in
+        { extid_loc
+        ; payload_loc = e.pexp_loc
+        ; normal
+        ; principal
+        }
+      | PStr [] ->
+        let s = { tag = ""; str = "" } in
+        { extid_loc
+        ; payload_loc  = { extid_loc with loc_start = extid_loc.loc_end }
+        ; normal    = s
+        ; principal = s
+        }
+      | _ -> invalid_payload ()
+    in
+    Some expectation
+  | _ ->
+    None
+
+(* Split a list of phrases from a .ml file *)
+let split_chunks phrases =
+  let rec loop (phrases : Parsetree.toplevel_phrase list) code_acc acc =
+    match phrases with
+    | [] ->
+      if code_acc = [] then
+        (List.rev acc, None)
+      else
+        (List.rev acc, Some (List.rev code_acc))
+    | phrase :: phrases ->
+      match phrase with
+      | Ptop_def [] -> loop phrases code_acc acc
+      | Ptop_def [{pstr_desc = Pstr_extension(ext, [])}] -> begin
+          match match_expect_extension ext with
+          | None -> loop phrases (phrase :: code_acc) acc
+          | Some expectation ->
+            let chunk =
+              { phrases     = List.rev code_acc
+              ; expectation
+              }
+            in
+            loop phrases [] (chunk :: acc)
+        end
+      | _ -> loop phrases (phrase :: code_acc) acc
+  in
+  loop phrases [] []
+
+module Compiler_messages = struct
+  let print_loc ppf (loc : Location.t) =
+    let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in
+    let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in
+    Format.fprintf ppf "Line _";
+    if startchar >= 0 then
+      Format.fprintf ppf ", characters %d-%d" startchar endchar;
+    Format.fprintf ppf ":@."
+
+  let rec error_reporter ppf ({loc; msg; sub; if_highlight=_} : Location.error)=
+    print_loc ppf loc;
+    Format.fprintf ppf "%a %s" Location.print_error_prefix () msg;
+    List.iter sub ~f:(fun err ->
+      Format.fprintf ppf "@\n@[<2>%a@]" error_reporter err)
+
+  let warning_printer loc ppf w =
+    if Warnings.is_active w then begin
+      print_loc ppf loc;
+      Format.fprintf ppf "Warning %a@." Warnings.print w
+    end
+
+  let capture ppf ~f =
+    Misc.protect_refs
+      [ R (Location.formatter_for_warnings , ppf            )
+      ; R (Location.warning_printer        , warning_printer)
+      ; R (Location.error_reporter         , error_reporter )
+      ]
+      f
+end
+
+let collect_formatters buf pps ~f =
+  List.iter (fun pp -> Format.pp_print_flush pp ()) pps;
+  let save =
+    List.map (fun pp -> Format.pp_get_formatter_out_functions pp ()) pps
+  in
+  let restore () =
+    List.iter2
+      (fun pp out_functions ->
+         Format.pp_print_flush pp ();
+         Format.pp_set_formatter_out_functions pp out_functions)
+      pps save
+  in
+  let out_string str ofs len = Buffer.add_substring buf str ofs len
+  and out_flush = ignore
+  and out_newline () = Buffer.add_char buf '\n'
+  and out_spaces n = for i = 1 to n do Buffer.add_char buf ' ' done in
+  let out_functions =
+    { Format.out_string; out_flush; out_newline; out_spaces }
+  in
+  List.iter
+    (fun pp -> Format.pp_set_formatter_out_functions pp out_functions)
+    pps;
+  match f () with
+  | x             -> restore (); x
+  | exception exn -> restore (); raise exn
+
+(* Invariant: ppf = Format.formatter_of_buffer buf *)
+let capture_everything buf ppf ~f =
+  collect_formatters buf [Format.std_formatter; Format.err_formatter]
+                     ~f:(fun () -> Compiler_messages.capture ppf ~f)
+
+let exec_phrase ppf phrase =
+  if !Clflags.dump_parsetree then Printast. top_phrase ppf phrase;
+  if !Clflags.dump_source    then Pprintast.top_phrase ppf phrase;
+  Toploop.execute_phrase true ppf phrase
+
+let parse_contents ~fname contents =
+  let lexbuf = Lexing.from_string contents in
+  Location.init lexbuf fname;
+  Location.input_name := fname;
+  Parse.use_file lexbuf
+
+let eval_expectation expectation ~output =
+  let s =
+    if !Clflags.principal then
+      expectation.principal
+    else
+      expectation.normal
+  in
+  if s.str = output then
+    None
+  else
+    let s = { s with str = output } in
+    Some (
+      if !Clflags.principal then
+        { expectation with principal = s }
+      else
+        { expectation with normal = s }
+    )
+
+let shift_lines delta phrases =
+  let position (pos : Lexing.position) =
+    { pos with pos_lnum = pos.pos_lnum + delta }
+  in
+  let location _this (loc : Location.t) =
+    { loc with
+      loc_start = position loc.loc_start
+    ; loc_end   = position loc.loc_end
+    }
+  in
+  let mapper = { Ast_mapper.default_mapper with location } in
+  List.map phrases ~f:(function
+    | Parsetree.Ptop_dir _ as p -> p
+    | Parsetree.Ptop_def st ->
+      Parsetree.Ptop_def (mapper.structure mapper st))
+
+let rec min_line_number : Parsetree.toplevel_phrase list -> int option =
+function
+  | [] -> None
+  | (Ptop_dir _  | Ptop_def []) :: l -> min_line_number l
+  | Ptop_def (st :: _) :: _ -> Some st.pstr_loc.loc_start.pos_lnum
+
+let eval_expect_file _fname ~file_contents =
+  Warnings.reset_fatal ();
+  let chunks, trailing_code =
+    parse_contents ~fname:"" file_contents |> split_chunks
+  in
+  let buf = Buffer.create 1024 in
+  let ppf = Format.formatter_of_buffer buf in
+  let exec_phrases phrases =
+    let phrases =
+      match min_line_number phrases with
+      | None -> phrases
+      | Some lnum -> shift_lines (1 - lnum) phrases
+    in
+    (* For formatting purposes *)
+    Buffer.add_char buf '\n';
+    let _ : bool =
+      List.fold_left phrases ~init:true ~f:(fun acc phrase ->
+        acc &&
+        try
+          exec_phrase ppf phrase
+        with exn ->
+          Location.report_exception ppf exn;
+          false)
+    in
+    Format.pp_print_flush ppf ();
+    let len = Buffer.length buf in
+    if len > 0 && Buffer.nth buf (len - 1) <> '\n' then
+      (* For formatting purposes *)
+      Buffer.add_char buf '\n';
+    let s = Buffer.contents buf in
+    Buffer.clear buf;
+    Misc.delete_eol_spaces s
+  in
+  let corrected_expectations =
+    capture_everything buf ppf ~f:(fun () ->
+      List.fold_left chunks ~init:[] ~f:(fun acc chunk ->
+        let output = exec_phrases chunk.phrases in
+        match eval_expectation chunk.expectation ~output with
+        | None -> acc
+        | Some correction -> correction :: acc)
+      |> List.rev)
+  in
+  let trailing_output =
+    match trailing_code with
+    | None -> ""
+    | Some phrases ->
+      capture_everything buf ppf ~f:(fun () -> exec_phrases phrases)
+  in
+  { corrected_expectations; trailing_output }
+
+let output_slice oc s a b =
+  output_string oc (String.sub s ~pos:a ~len:(b - a))
+
+let output_corrected oc ~file_contents correction =
+  let output_body oc { str; tag } =
+    Printf.fprintf oc "{%s|%s|%s}" tag str tag
+  in
+  let ofs =
+    List.fold_left correction.corrected_expectations ~init:0
+      ~f:(fun ofs c ->
+        output_slice oc file_contents ofs c.payload_loc.loc_start.pos_cnum;
+        output_body oc c.normal;
+        if c.normal.str <> c.principal.str then begin
+          output_string oc ", Principal";
+          output_body oc c.principal
+        end;
+        c.payload_loc.loc_end.pos_cnum)
+  in
+  output_slice oc file_contents ofs (String.length file_contents);
+  match correction.trailing_output with
+  | "" -> ()
+  | s  -> Printf.fprintf oc "\n[%%%%expect{|%s|}]\n" s
+
+let write_corrected ~file ~file_contents correction =
+  let oc = open_out file in
+  output_corrected oc ~file_contents correction;
+  close_out oc
+
+let process_expect_file fname =
+  let corrected_fname = fname ^ ".corrected" in
+  let file_contents =
+    let ic = open_in_bin fname in
+    match really_input_string ic (in_channel_length ic) with
+    | s           -> close_in ic; Misc.normalise_eol s
+    | exception e -> close_in ic; raise e
+  in
+  let correction = eval_expect_file fname ~file_contents in
+  write_corrected ~file:corrected_fname ~file_contents correction
+
+let repo_root = ref ""
+
+let main fname =
+  Toploop.override_sys_argv
+    (Array.sub Sys.argv ~pos:!Arg.current
+       ~len:(Array.length Sys.argv - !Arg.current));
+  (* Ignore OCAMLRUNPARAM=b to be reproducible *)
+  Printexc.record_backtrace false;
+  List.iter [ "stdlib" ] ~f:(fun s ->
+    Topdirs.dir_directory (Filename.concat !repo_root s));
+  Toploop.initialize_toplevel_env ();
+  Sys.interactive := false;
+  process_expect_file fname;
+  exit 0
+
+let args =
+  Arg.align
+    [ "-repo-root", Set_string repo_root,
+      "
 root of the OCaml repository"
+    ; "-principal", Set Clflags.principal,
+      " Evaluate the file with -principal set"
+    ]
+
+let usage = "Usage: expect_test  [script-file [arguments]]\n\
+             options are:"
+
+let () =
+  try
+    Arg.parse args main usage;
+    Printf.eprintf "expect_test: no input file\n";
+    exit 2
+  with exn ->
+    Location.report_exception Format.err_formatter exn;
+    exit 2
diff --git a/tools/.depend b/tools/.depend
index 7ef2e505..b578b0ec 100644
--- a/tools/.depend
+++ b/tools/.depend
@@ -1,5 +1,3 @@
-depend.cmi : ../parsing/parsetree.cmi ../parsing/longident.cmi
-profiling.cmi :
 addlabels.cmo : ../parsing/parsetree.cmi ../parsing/parse.cmi \
     ../parsing/longident.cmi ../parsing/location.cmi ../parsing/asttypes.cmi
 addlabels.cmx : ../parsing/parsetree.cmi ../parsing/parse.cmx \
@@ -20,12 +18,6 @@ cmt2annot.cmx : ../typing/untypeast.cmx ../typing/types.cmx \
     ../parsing/asttypes.cmi ../typing/annot.cmi
 cvt_emit.cmo :
 cvt_emit.cmx :
-depend.cmo : ../parsing/parsetree.cmi ../utils/misc.cmi \
-    ../parsing/longident.cmi ../parsing/location.cmi ../utils/clflags.cmi \
-    ../parsing/builtin_attributes.cmi ../parsing/asttypes.cmi depend.cmi
-depend.cmx : ../parsing/parsetree.cmi ../utils/misc.cmx \
-    ../parsing/longident.cmx ../parsing/location.cmx ../utils/clflags.cmx \
-    ../parsing/builtin_attributes.cmx ../parsing/asttypes.cmi depend.cmi
 dumpobj.cmo : ../utils/tbl.cmi opnames.cmo ../bytecomp/opcodes.cmo \
     ../parsing/location.cmi ../bytecomp/lambda.cmi ../bytecomp/instruct.cmi \
     ../typing/ident.cmi ../utils/config.cmi ../bytecomp/cmo_format.cmi \
@@ -57,11 +49,13 @@ ocamlcp.cmx : ../driver/main_args.cmx
 ocamldep.cmo : ../driver/pparse.cmi ../parsing/parsetree.cmi \
     ../parsing/parser.cmi ../parsing/parse.cmi ../utils/misc.cmi \
     ../parsing/longident.cmi ../parsing/location.cmi ../parsing/lexer.cmi \
-    depend.cmi ../utils/config.cmi ../driver/compenv.cmi ../utils/clflags.cmi
+    ../parsing/depend.cmi ../utils/config.cmi ../driver/compenv.cmi \
+    ../utils/clflags.cmi
 ocamldep.cmx : ../driver/pparse.cmx ../parsing/parsetree.cmi \
     ../parsing/parser.cmx ../parsing/parse.cmx ../utils/misc.cmx \
     ../parsing/longident.cmx ../parsing/location.cmx ../parsing/lexer.cmx \
-    depend.cmx ../utils/config.cmx ../driver/compenv.cmx ../utils/clflags.cmx
+    ../parsing/depend.cmx ../utils/config.cmx ../driver/compenv.cmx \
+    ../utils/clflags.cmx
 ocamlmklib.cmo : ocamlmklibconfig.cmo ../utils/config.cmi
 ocamlmklib.cmx : ocamlmklibconfig.cmx ../utils/config.cmx
 ocamlmklibconfig.cmo :
@@ -80,6 +74,7 @@ primreq.cmo : ../utils/config.cmi ../bytecomp/cmo_format.cmi
 primreq.cmx : ../utils/config.cmx ../bytecomp/cmo_format.cmi
 profiling.cmo : profiling.cmi
 profiling.cmx : profiling.cmi
+profiling.cmi :
 read_cmt.cmo : ../typing/cmt_format.cmi cmt2annot.cmo ../utils/clflags.cmi
 read_cmt.cmx : ../typing/cmt_format.cmx cmt2annot.cmx ../utils/clflags.cmx
 scrapelabels.cmo :
diff --git a/tools/Makefile b/tools/Makefile
index 0e91277c..7ab2f11f 100644
--- a/tools/Makefile
+++ b/tools/Makefile
@@ -14,15 +14,3 @@
 #**************************************************************************
 
 include Makefile.shared
-
-# To make custom toplevels
-
-ocamlmktop: ocamlmktop.tpl ../config/Makefile
-	sed -e 's|%%BINDIR%%|$(BINDIR)|' ocamlmktop.tpl > ocamlmktop
-	chmod +x ocamlmktop
-
-install::
-	cp ocamlmktop "$(INSTALL_BINDIR)"
-
-clean::
-	rm -f ocamlmktop
diff --git a/tools/Makefile.nt b/tools/Makefile.nt
index 3a16f967..8ebcf29e 100644
--- a/tools/Makefile.nt
+++ b/tools/Makefile.nt
@@ -16,20 +16,9 @@
 include Makefile.shared
 
 ifneq "$(wildcard ../flexdll/Makefile)" ""
-  CAMLOPT:=OCAML_FLEXLINK="../boot/ocamlrun ../flexdll/flexlink.exe" $(CAMLOPT)
+CAMLOPT := OCAML_FLEXLINK="../boot/ocamlrun ../flexdll/flexlink.exe" \
+  $(CAMLOPT)
 endif
 
-# To make custom toplevels
-
-OCAMLMKTOP=ocamlmktop.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)
-
-install::
-	cp ocamlmktop "$(INSTALL_BINDIR)/ocamlmktop$(EXE)"
-
 clean::
-	rm -f ocamlmktop objinfo_helper$(EXE).manifest
+	rm -f "objinfo_helper$(EXE).manifest"
diff --git a/tools/Makefile.shared b/tools/Makefile.shared
index 1a24391f..2803d786 100644
--- a/tools/Makefile.shared
+++ b/tools/Makefile.shared
@@ -12,48 +12,107 @@
 #*   special exception on linking described in the file LICENSE.          *
 #*                                                                        *
 #**************************************************************************
-
+MAKEFLAGS := -r -R
 include ../config/Makefile
+INSTALL_BINDIR:=$(DESTDIR)$(BINDIR)
+INSTALL_LIBDIR:=$(DESTDIR)$(LIBDIR)
+INSTALL_COMPLIBDIR:=$(DESTDIR)$(COMPLIBDIR)
+INSTALL_STUBLIBDIR:=$(DESTDIR)$(STUBLIBDIR)
+INSTALL_MANDIR:=$(DESTDIR)$(MANDIR)
+
+ifeq ($(SYSTEM),unix)
+override define shellquote
+$i := $$(subst ",\",$$(subst $$$$,\$$$$,$$(subst `,\`,$i)))#")#
+endef
+$(foreach i,BINDIR LIBDIR COMPLIBDIR STUBLIBDIR MANDIR,$(eval $(shellquote)))
+endif
+
 CAMLRUN ?= ../boot/ocamlrun
 CAMLYACC ?= ../boot/ocamlyacc
+DESTDIR ?=
+# Setup GNU make variables storing per-target source and target,
+# a list of installed tools, and a function to quote a filename for
+# the shell.
+override installed_tools := ocamldep ocamlprof ocamlcp ocamloptp \
+                   ocamlmktop ocamlmklib ocamlobjinfo
+
+install_files :=
+define byte2native
+$(patsubst %.cmo,%.cmx,$(patsubst %.cma,%.cmxa,$1))
+endef
+
+# $1 = target, $2 = OCaml object dependencies, $3 = other dependencies
+# There is a lot of subtle code here.  The multiple layers of expansion
+# are due to `make`'s eval() function, which evaluates the string
+# passed to it as a makefile fragment.  So it is crucial that variables
+# not get expanded too many times.
+define byte_and_opt_
+# This check is defensive programming
+$(and $(filter-out 1,$(words $1)),$(error \
+   cannot build file with whitespace in name))
+$1: $3 $2
+	$$(CAMLC) $$(LINKFLAGS) -I .. -o $$@ $2
+
+$1.opt: $3 $$(call byte2native,$2)
+	$$(CAMLOPT) $$(LINKFLAGS) -I .. -o $$@ $$(call byte2native,$2)
+
+all: $1
+
+opt.opt: $1.opt
+
+ifeq '$(filter $(installed_tools),$1)' '$1'
+install_files += $1
+endif
+clean::
+	rm -f -- $1 $1.opt
+
+endef
 
-CAMLC=$(CAMLRUN) ../boot/ocamlc -nostdlib -I ../boot
+# Escape any $ characters in the arguments and eval the result.
+define byte_and_opt
+$(eval $(call \
+ byte_and_opt_,$(subst $$,$$$$,$1),$(subst $$,$$$$,$2),$(subst $$,$$$$,$3)))
+endef
+
+ROOTDIR=..
+
+ifeq "$(wildcard $(ROOTDIR)/flexdll/Makefile)" ""
+export OCAML_FLEXLINK:=
+else
+export OCAML_FLEXLINK:=$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/flexdll/flexlink.exe
+endif
+
+CAMLC=$(CAMLRUN) ../boot/ocamlc -nostdlib -I ../boot \
+      -use-prims ../byterun/primitives -I ..
 CAMLOPT=$(CAMLRUN) ../ocamlopt -nostdlib -I ../stdlib
 CAMLLEX=$(CAMLRUN) ../boot/ocamllex
 INCLUDES=-I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../asmcomp \
          -I ../middle_end -I ../middle_end/base_types -I ../driver \
          -I ../toplevel
-COMPFLAGS= -strict-sequence -w +27+32..39 -warn-error A -safe-string $(INCLUDES)
+COMPFLAGS= -absname -w +a-4-9-41-42-44-45-48 -strict-sequence -warn-error A \
+ -safe-string -strict-formats $(INCLUDES)
 LINKFLAGS=$(INCLUDES)
-
-all: ocamldep ocamlprof ocamlcp ocamloptp ocamlmktop ocamlmklib dumpobj \
-     objinfo read_cmt stripdebug cmpbyt
+VPATH := $(filter-out -I,$(INCLUDES))
 
 # scrapelabels addlabels
 
-.PHONY: all
-
-opt.opt: ocamldep.opt read_cmt.opt
-.PHONY: opt.opt
+.PHONY: all opt.opt
 
 # The dependency generator
 
-CAMLDEP_OBJ=depend.cmo ocamldep.cmo
+CAMLDEP_OBJ=ocamldep.cmo
 CAMLDEP_IMPORTS=timings.cmo misc.cmo config.cmo identifiable.cmo numbers.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 ast_iterator.cmo \
   builtin_attributes.cmo ast_invariants.cmo \
-  pparse.cmo compenv.cmo
-
-ocamldep: depend.cmi $(CAMLDEP_OBJ)
-	$(CAMLC) $(LINKFLAGS) -compat-32 -o ocamldep $(CAMLDEP_IMPORTS) \
-	         $(CAMLDEP_OBJ)
+  pparse.cmo compenv.cmo depend.cmo
 
-ocamldep.opt: depend.cmi $(CAMLDEP_OBJ:.cmo=.cmx)
-	$(CAMLOPT) $(LINKFLAGS) -o ocamldep.opt $(CAMLDEP_IMPORTS:.cmo=.cmx) \
-	           $(CAMLDEP_OBJ:.cmo=.cmx)
+ocamldep: LINKFLAGS += -compat-32
+$(call byte_and_opt,ocamldep,$(CAMLDEP_IMPORTS) $(CAMLDEP_OBJ),)
+ocamldep: depend.cmi
+ocamldep.opt: depend.cmi
 
 # ocamldep is precious: sometimes we are stuck in the middle of a
 # bootstrap and we need to remake the dependencies
@@ -62,14 +121,6 @@ clean::
 	rm -f ocamldep.opt
 
 
-INSTALL_BINDIR=$(DESTDIR)$(BINDIR)
-INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
-
-install::
-	cp ocamldep "$(INSTALL_BINDIR)/ocamldep$(EXE)"
-	if test -f ocamldep.opt; then \
-	  cp ocamldep.opt "$(INSTALL_BINDIR)/ocamldep.opt$(EXE)"; else :; fi
-
 # The profiler
 
 CSLPROF=ocamlprof.cmo
@@ -78,46 +129,27 @@ CSLPROF_IMPORTS=misc.cmo config.cmo identifiable.cmo numbers.cmo \
   warnings.cmo location.cmo longident.cmo docstrings.cmo \
   syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo
 
-ocamlprof: $(CSLPROF) profiling.cmo
-	$(CAMLC) $(LINKFLAGS) -o ocamlprof $(CSLPROF_IMPORTS) $(CSLPROF)
+$(call byte_and_opt,ocamlprof,$(CSLPROF_IMPORTS) profiling.cmo $(CSLPROF),)
 
-ocamlcp: 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
+ocamlcp_cmos = misc.cmo warnings.cmo config.cmo identifiable.cmo numbers.cmo \
+	       arg_helper.cmo clflags.cmo main_args.cmo
 
-ocamloptp: ocamloptp.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
+$(call byte_and_opt,ocamlcp,$(ocamlcp_cmos) ocamlcp.cmo,)
+$(call byte_and_opt,ocamloptp,$(ocamlcp_cmos) ocamloptp.cmo,)
 
 opt:: profiling.cmx
 
 install::
-	cp ocamlprof "$(INSTALL_BINDIR)/ocamlprof$(EXE)"
-	cp ocamlcp "$(INSTALL_BINDIR)/ocamlcp$(EXE)"
-	cp ocamloptp "$(INSTALL_BINDIR)/ocamloptp$(EXE)"
-	cp profiling.cmi profiling.cmo "$(INSTALL_LIBDIR)"
+	cp -- profiling.cmi profiling.cmo "$(INSTALL_LIBDIR)"
 
 installopt::
-	cp profiling.cmx profiling.$(O) "$(INSTALL_LIBDIR)"
-
-clean::
-	rm -f ocamlprof ocamlcp ocamloptp
-
+	cp -- profiling.cmx profiling.$(O) "$(INSTALL_LIBDIR)"
 
 # To help building mixed-mode libraries (OCaml + C)
 
-ocamlmklib: ocamlmklibconfig.cmo ocamlmklib.cmo
-	$(CAMLC) $(LINKFLAGS) -o ocamlmklib ocamlmklibconfig.cmo config.cmo \
-	         ocamlmklib.cmo
-
-install::
-	cp ocamlmklib "$(INSTALL_BINDIR)/ocamlmklib$(EXE)"
+$(call byte_and_opt,ocamlmklib,ocamlmklibconfig.cmo config.cmo \
+	         ocamlmklib.cmo,)
 
-clean::
-	rm -f ocamlmklib
 
 ocamlmklibconfig.ml: ../config/Makefile Makefile
 	(echo 'let bindir = "$(BINDIR)"'; \
@@ -134,6 +166,14 @@ beforedepend:: ocamlmklibconfig.ml
 clean::
 	rm -f ocamlmklibconfig.ml
 
+# To make custom toplevels
+
+OCAMLMKTOP=ocamlmktop.cmo
+OCAMLMKTOP_IMPORTS=misc.cmo identifiable.cmo numbers.cmo config.cmo \
+		   arg_helper.cmo clflags.cmo ccomp.cmo
+
+$(call byte_and_opt,ocamlmktop,$(OCAMLMKTOP_IMPORTS) $(OCAMLMKTOP),)
+
 # Converter olabl/ocaml 2.99 to ocaml 3
 
 OCAML299TO3= lexer299.cmo ocaml299to3.cmo
@@ -181,6 +221,24 @@ addlabels: addlabels.cmo
 #install::
 #	cp addlabels "$(INSTALL_LIBDIR)"
 
+ifeq ($(UNIX_OR_WIN32),unix)
+LN := ln -sf
+else
+LN := cp -pf
+endif
+
+install::
+	for i in $(install_files); \
+	do \
+	  cp -- "$$i" "$(INSTALL_BINDIR)/$$i.byte$(EXE)" && \
+	  if test -f "$$i".opt; then \
+	    cp -- "$$i.opt" "$(INSTALL_BINDIR)/$$i.opt$(EXE)" && \
+	    (cd "$(INSTALL_BINDIR)/" && $(LN) "$$i.opt$(EXE)" "$$i$(EXE)"); \
+	  else \
+	    (cd "$(INSTALL_BINDIR)/" && $(LN) "$$i.byte$(EXE)" "$$i$(EXE)"); \
+	  fi; \
+	done
+
 clean::
 	rm -f addlabels
 
@@ -193,6 +251,7 @@ cvt_emit: $(CVT_EMIT)
 
 # cvt_emit is precious: sometimes we are stuck in the middle of a
 # bootstrap and we need to remake the dependencies
+.PRECIOUS: cvt_emit
 clean::
 	if test -f cvt_emit; then mv -f cvt_emit cvt_emit.bak; else :; fi
 
@@ -204,7 +263,6 @@ clean::
 
 beforedepend:: cvt_emit.ml
 
-
 # Reading cmt files
 
 READ_CMT= \
@@ -213,32 +271,17 @@ READ_CMT= \
           \
           cmt2annot.cmo read_cmt.cmo
 
-READ_CMT_OPT1 = $(READ_CMT:.cmo=.cmx)
-READ_CMT_OPT = $(READ_CMT_OPT1:.cma=.cmxa)
-
-read_cmt: $(READ_CMT)
-	$(CAMLC) $(LINKFLAGS) -o read_cmt $(READ_CMT)
-
-read_cmt.opt: $(READ_CMT_OPT)
-	$(CAMLOPT) $(LINKFLAGS) -o read_cmt.opt $(READ_CMT_OPT)
-
-clean::
-	rm -f read_cmt read_cmt.opt
+# Reading cmt files
+$(call byte_and_opt,read_cmt,$(READ_CMT),)
 
-beforedepend::
 
 # The bytecode disassembler
 
 DUMPOBJ=opnames.cmo dumpobj.cmo
 
-dumpobj: $(DUMPOBJ)
-	$(CAMLC) $(LINKFLAGS) -o dumpobj \
-	         misc.cmo identifiable.cmo numbers.cmo \
-                 tbl.cmo config.cmo ident.cmo \
-	         opcodes.cmo bytesections.cmo $(DUMPOBJ)
-
-clean::
-	rm -f dumpobj
+$(call byte_and_opt,dumpobj,misc.cmo identifiable.cmo numbers.cmo tbl.cmo \
+                    config.cmo ident.cmo opcodes.cmo bytesections.cmo \
+		    $(DUMPOBJ),)
 
 opnames.ml: ../byterun/caml/instruct.h
 	unset LC_ALL || : ; \
@@ -283,37 +326,25 @@ OBJINFO=../compilerlibs/ocamlcommon.cma \
         ../asmcomp/export_info.cmo \
         objinfo.cmo
 
-objinfo: objinfo_helper$(EXE) $(OBJINFO)
-	$(CAMLC) -o objinfo $(OBJINFO)
+$(call byte_and_opt,ocamlobjinfo,$(OBJINFO),objinfo_helper$(EXE))
 
 install::
-	cp objinfo "$(INSTALL_BINDIR)/ocamlobjinfo$(EXE)"
 	cp objinfo_helper$(EXE) "$(INSTALL_LIBDIR)/objinfo_helper$(EXE)"
 
-clean::
-	rm -f objinfo objinfo_helper$(EXE)
-
 # Scan object files for required primitives
-
-PRIMREQ=primreq.cmo
-
-primreq: $(PRIMREQ)
-	$(CAMLC) $(LINKFLAGS) -o primreq config.cmo $(PRIMREQ)
+$(call byte_and_opt,primreq,config.cmo primreq.cmo,)
 
 clean::
-	rm -f primreq
+	rm -f "objinfo_helper$(EXE)"
+
 
 # Copy a bytecode executable, stripping debug info
 
-STRIPDEBUG=../compilerlibs/ocamlcommon.cma \
+stripdebug=../compilerlibs/ocamlcommon.cma \
            ../compilerlibs/ocamlbytecomp.cma \
            stripdebug.cmo
 
-stripdebug: $(STRIPDEBUG)
-	$(CAMLC) $(LINKFLAGS) -o stripdebug $(STRIPDEBUG)
-
-clean::
-	rm -f stripdebug
+$(call byte_and_opt,stripdebug,$(stripdebug),)
 
 # Compare two bytecode executables
 
@@ -321,36 +352,31 @@ CMPBYT=../compilerlibs/ocamlcommon.cma \
        ../compilerlibs/ocamlbytecomp.cma \
        cmpbyt.cmo
 
-cmpbyt: $(CMPBYT)
-	$(CAMLC) $(LINKFLAGS) -o cmpbyt $(CMPBYT)
-
-clean::
-	rm -f cmpbyt
+$(call byte_and_opt,cmpbyt,$(CMPBYT),)
 
 ifeq "$(RUNTIMEI)" "true"
 install::
-	cp ocaml-instr-graph ocaml-instr-report $(INSTALL_BINDIR)/
+	cp ocaml-instr-graph ocaml-instr-report "$(INSTALL_BINDIR)/"
 endif
 
 # Common stuff
 
 .SUFFIXES:
-.SUFFIXES: .ml .cmo .mli .cmi .cmx
 
-.ml.cmo:
-	$(CAMLC) -c $(COMPFLAGS) $<
+%.cmo: %.ml
+	$(CAMLC) -c $(COMPFLAGS) - $<
 
-.mli.cmi:
-	$(CAMLC) -c $(COMPFLAGS) $<
+%.cmi: %.mli
+	$(CAMLC) -c $(COMPFLAGS) - $<
 
-.ml.cmx:
-	$(CAMLOPT) $(COMPFLAGS) -c $<
+%.cmx: %.ml
+	$(CAMLOPT) $(COMPFLAGS) -c - $<
 
 clean::
 	rm -f *.cmo *.cmi *.cma *.dll *.so *.lib *.a
 
 depend: beforedepend
-	$(CAMLRUN) ./ocamldep $(INCLUDES) *.mli *.ml > .depend
+	$(CAMLRUN) ./ocamldep -slash $(INCLUDES) *.mli *.ml > .depend
 
 .PHONY: clean install beforedepend depend
 
diff --git a/tools/check-typo b/tools/check-typo
index 9b6c7c6f..a19943a6 100755
--- a/tools/check-typo
+++ b/tools/check-typo
@@ -237,6 +237,7 @@ IGNORE_DIRS="
         state == "close" && $0 ~ /\*{74}/ { state = "OK"; }
         state == "close" { state = "(last line)"; }
         state == "blurb" && $0 ~ /\* {72}\*/ { state = "close"; }
+        state == "blurb" && $0 ~ /\/LICENSE/ { state = "(license path)" }
         state == "blurb1" && $0 ~ /\*   All rights reserved. .{47} \*/ \
                                                  { state = "blurb"; }
         state == "blurb1" { state = "(blurb line 1)"; }
diff --git a/tools/ci-build b/tools/ci-build
index 6d9439e3..8e0969cd 100755
--- a/tools/ci-build
+++ b/tools/ci-build
@@ -23,8 +23,9 @@
 #    for windows, this is relative to $HOME/jenkins-workspace
 #    for bsd, macos, linux, this is ignored and the build is always in .
 # 3. options:
-#    -conf configure-option
+#    -conf configure-option  add configure-option to configure cmd line
 #    -patch1 file-name       apply patch with -p1
+#    -newmakefiles           do not use Makefile.nt even for Windows
 
 error () {
   echo "$1" >&2
@@ -81,7 +82,8 @@ set -ex
 make=make
 instdir="$HOME/ocaml-tmp-install"
 docheckout=false
-nt=
+makefile=Makefile
+configure=unix
 
 case "$arch" in
   bsd)
@@ -102,25 +104,29 @@ case "$arch" in
     instdir=/cygdrive/c/ocamlmgw
     workdir="$HOME/jenkins-workspace/$branch"
     docheckout=true
-    nt=.nt
+    makefile=Makefile.nt
+    configure=nt
   ;;
   mingw64)
     instdir=/cygdrive/c/ocamlmgw64
     workdir="$HOME/jenkins-workspace/$branch"
     docheckout=true
-    nt=.nt
+    makefile=Makefile.nt
+    configure=nt
   ;;
   msvc)
     instdir=/cygdrive/c/ocamlms
     workdir="$HOME/jenkins-workspace/$branch"
     docheckout=true
-    nt=.nt
+    makefile=Makefile.nt
+    configure=nt
   ;;
   msvc64)
     instdir=/cygdrive/c/ocamlms64
     workdir="$HOME/jenkins-workspace/$branch"
     docheckout=true
-    nt=.nt
+    makefile=Makefile.nt
+    configure=nt
   ;;
   *) error "unknown architecture: $arch";;
 esac
@@ -138,10 +144,12 @@ cd "$workdir"
 confoptions=""
 while [ $# -gt 0 ]; do
   case $1 in
-    -conf) confoptions="$confoptions `quote1 "$2"`"; shift 2;;
-    -patch1) patch -f -p1 <"$2"; shift 2;;
+    -conf) confoptions="$confoptions `quote1 "$2"`"; shift;;
+    -patch1) patch -f -p1 <"$2"; shift;;
+    -newmakefiles) makefile=Makefile;;
     *) error "unknown option $1";;
   esac
+  shift
 done
 
 #########################################################################
@@ -150,15 +158,15 @@ done
 # Tell gcc to use only ASCII in its diagnostic outputs.
 export LC_ALL=C
 
-$make -f Makefile$nt distclean || :
+$make -f $makefile distclean || :
 
 if $docheckout; then
   git pull
 fi
 
-case $nt in
-  "") eval "./configure -prefix '$instdir' $confoptions";;
-  .nt)
+case $configure in
+  unix) eval "./configure -prefix '$instdir' $confoptions";;
+  nt)
     cp config/m-nt.h config/m.h
     cp config/s-nt.h config/s.h
     cp config/Makefile.$arch config/Makefile
@@ -166,8 +174,8 @@ case $nt in
   *) error "internal error";;
 esac
 
-$make -f Makefile$nt world.opt
-$make -f Makefile$nt install
+$make -f $makefile world.opt
+$make -f $makefile install
 
 rm -rf "$instdir"
 cd testsuite
diff --git a/tools/cmpbyt.ml b/tools/cmpbyt.ml
index e6b42434..983234fe 100644
--- a/tools/cmpbyt.ml
+++ b/tools/cmpbyt.ml
@@ -84,4 +84,4 @@ let _ =
     eprintf "Usage: cmpbyt  \n";
     exit 2
   end;
-  if cmpbyt Sys.argv.(1) Sys.argv.(2) then exit 0 else exit 2
+  if cmpbyt Sys.argv.(1) Sys.argv.(2) then exit 0 else exit 1
diff --git a/tools/depend.ml b/tools/depend.ml
deleted file mode 100644
index a29f8435..00000000
--- a/tools/depend.ml
+++ /dev/null
@@ -1,515 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-open Asttypes
-open Location
-open Longident
-open Parsetree
-
-module StringSet = Set.Make(struct type t = string let compare = compare end)
-module StringMap = Map.Make(String)
-
-(* Module resolution map *)
-(* Node (set of imports for this path, map for submodules) *)
-type map_tree = Node of StringSet.t * bound_map
-and  bound_map = map_tree StringMap.t
-let bound = Node (StringSet.empty, StringMap.empty)
-
-(*let get_free (Node (s, _m)) = s*)
-let get_map (Node (_s, m)) = m
-let make_leaf s = Node (StringSet.singleton s, StringMap.empty)
-let make_node m =  Node (StringSet.empty, m)
-let rec weaken_map s (Node(s0,m0)) =
-  Node (StringSet.union s s0, StringMap.map (weaken_map s) m0)
-let rec collect_free (Node (s, m)) =
-  StringMap.fold (fun _ n -> StringSet.union (collect_free n)) m s
-
-(* Returns the imports required to access the structure at path p *)
-(* Only raises Not_found if the head of p is not in the toplevel map *)
-let rec lookup_free p m =
-  match p with
-    [] -> raise Not_found
-  | s::p ->
-      let Node (f, m') = StringMap.find s m  in
-      try lookup_free p m' with Not_found -> f
-
-(* Returns the node corresponding to the structure at path p *)
-let rec lookup_map lid m =
-  match lid with
-    Lident s    -> StringMap.find s m
-  | Ldot (l, s) -> StringMap.find s (get_map (lookup_map l m))
-  | Lapply _    -> raise Not_found
-
-(* Collect free module identifiers in the a.s.t. *)
-
-let free_structure_names = ref StringSet.empty
-
-let add_names s =
-  free_structure_names := StringSet.union s !free_structure_names
-
-let rec add_path bv ?(p=[]) = function
-  | Lident s ->
-      let free =
-        try lookup_free (s::p) bv with Not_found -> StringSet.singleton s
-      in
-      (*StringSet.iter (fun s -> Printf.eprintf "%s " s) free;
-        prerr_endline "";*)
-      add_names free
-  | Ldot(l, s) -> add_path bv ~p:(s::p) l
-  | Lapply(l1, l2) -> add_path bv l1; add_path bv l2
-
-let open_module bv lid =
-  match lookup_map lid bv with
-  | Node (s, m) ->
-      add_names s;
-      StringMap.fold StringMap.add m bv
-  | exception Not_found ->
-      add_path bv lid; bv
-
-let add_parent bv lid =
-  match lid.txt with
-    Ldot(l, _s) -> add_path bv l
-  | _ -> ()
-
-let add = add_parent
-
-let addmodule bv lid = add_path bv lid.txt
-
-let handle_extension ext =
-  match (fst ext).txt with
-  | "error" | "ocaml.error" ->
-    raise (Location.Error
-             (Builtin_attributes.error_of_extension ext))
-  | _ ->
-    ()
-
-let rec add_type bv ty =
-  match ty.ptyp_desc with
-    Ptyp_any -> ()
-  | Ptyp_var _ -> ()
-  | Ptyp_arrow(_, t1, t2) -> add_type bv t1; add_type bv t2
-  | Ptyp_tuple tl -> List.iter (add_type bv) tl
-  | Ptyp_constr(c, tl) -> add bv c; List.iter (add_type bv) tl
-  | Ptyp_object (fl, _) -> List.iter (fun (_, _, t) -> add_type bv t) fl
-  | Ptyp_class(c, tl) -> add bv c; List.iter (add_type bv) tl
-  | Ptyp_alias(t, _) -> add_type bv t
-  | Ptyp_variant(fl, _, _) ->
-      List.iter
-        (function Rtag(_,_,_,stl) -> List.iter (add_type bv) stl
-          | Rinherit sty -> add_type bv sty)
-        fl
-  | Ptyp_poly(_, t) -> add_type bv t
-  | Ptyp_package pt -> add_package_type bv pt
-  | Ptyp_extension e -> handle_extension e
-
-and add_package_type bv (lid, l) =
-  add bv lid;
-  List.iter (add_type bv) (List.map (fun (_, e) -> e) l)
-
-let add_opt add_fn bv = function
-    None -> ()
-  | Some x -> add_fn bv x
-
-let add_constructor_arguments bv = function
-  | Pcstr_tuple l -> List.iter (add_type bv) l
-  | Pcstr_record l -> List.iter (fun l -> add_type bv l.pld_type) l
-
-let add_constructor_decl bv pcd =
-  add_constructor_arguments bv pcd.pcd_args;
-  Misc.may (add_type bv) pcd.pcd_res
-
-let add_type_declaration bv td =
-  List.iter
-    (fun (ty1, ty2, _) -> add_type bv ty1; add_type bv ty2)
-    td.ptype_cstrs;
-  add_opt add_type bv td.ptype_manifest;
-  let add_tkind = function
-    Ptype_abstract -> ()
-  | Ptype_variant cstrs ->
-      List.iter (add_constructor_decl bv) cstrs
-  | Ptype_record lbls ->
-      List.iter (fun pld -> add_type bv pld.pld_type) lbls
-  | Ptype_open -> () in
-  add_tkind td.ptype_kind
-
-let add_extension_constructor bv ext =
-  match ext.pext_kind with
-    Pext_decl(args, rty) ->
-      add_constructor_arguments bv args;
-      Misc.may (add_type bv) rty
-  | Pext_rebind lid -> add bv lid
-
-let add_type_extension bv te =
-  add bv te.ptyext_path;
-  List.iter (add_extension_constructor bv) te.ptyext_constructors
-
-let rec add_class_type bv cty =
-  match cty.pcty_desc with
-    Pcty_constr(l, tyl) ->
-      add bv l; List.iter (add_type bv) tyl
-  | Pcty_signature { pcsig_self = ty; pcsig_fields = fieldl } ->
-      add_type bv ty;
-      List.iter (add_class_type_field bv) fieldl
-  | Pcty_arrow(_, ty1, cty2) ->
-      add_type bv ty1; add_class_type bv cty2
-  | Pcty_extension e -> handle_extension e
-
-and add_class_type_field bv pctf =
-  match pctf.pctf_desc with
-    Pctf_inherit cty -> add_class_type bv cty
-  | Pctf_val(_, _, _, ty) -> add_type bv ty
-  | Pctf_method(_, _, _, ty) -> add_type bv ty
-  | Pctf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2
-  | Pctf_attribute _ -> ()
-  | Pctf_extension e -> handle_extension e
-
-let add_class_description bv infos =
-  add_class_type bv infos.pci_expr
-
-let add_class_type_declaration = add_class_description
-
-let pattern_bv = ref StringMap.empty
-
-let rec add_pattern bv pat =
-  match pat.ppat_desc with
-    Ppat_any -> ()
-  | Ppat_var _ -> ()
-  | Ppat_alias(p, _) -> add_pattern bv p
-  | Ppat_interval _
-  | Ppat_constant _ -> ()
-  | Ppat_tuple pl -> List.iter (add_pattern bv) pl
-  | Ppat_construct(c, op) -> add bv c; add_opt add_pattern bv op
-  | Ppat_record(pl, _) ->
-      List.iter (fun (lbl, p) -> add bv lbl; add_pattern bv p) pl
-  | Ppat_array pl -> List.iter (add_pattern bv) pl
-  | Ppat_or(p1, p2) -> add_pattern bv p1; add_pattern bv p2
-  | Ppat_constraint(p, ty) -> add_pattern bv p; add_type bv ty
-  | Ppat_variant(_, op) -> add_opt add_pattern bv op
-  | Ppat_type li -> add bv li
-  | Ppat_lazy p -> add_pattern bv p
-  | Ppat_unpack id -> pattern_bv := StringMap.add id.txt bound !pattern_bv
-  | Ppat_exception p -> add_pattern bv p
-  | Ppat_extension e -> handle_extension e
-
-let add_pattern bv pat =
-  pattern_bv := bv;
-  add_pattern bv pat;
-  !pattern_bv
-
-let rec add_expr bv exp =
-  match exp.pexp_desc with
-    Pexp_ident l -> add bv l
-  | Pexp_constant _ -> ()
-  | Pexp_let(rf, pel, e) ->
-      let bv = add_bindings rf bv pel in add_expr bv e
-  | Pexp_fun (_, opte, p, e) ->
-      add_opt add_expr bv opte; add_expr (add_pattern bv p) e
-  | Pexp_function pel ->
-      add_cases bv pel
-  | Pexp_apply(e, el) ->
-      add_expr bv e; List.iter (fun (_,e) -> add_expr bv e) el
-  | Pexp_match(e, pel) -> add_expr bv e; add_cases bv pel
-  | Pexp_try(e, pel) -> add_expr bv e; add_cases bv pel
-  | Pexp_tuple el -> List.iter (add_expr bv) el
-  | Pexp_construct(c, opte) -> add bv c; add_opt add_expr bv opte
-  | Pexp_variant(_, opte) -> add_opt add_expr bv opte
-  | Pexp_record(lblel, opte) ->
-      List.iter (fun (lbl, e) -> add bv lbl; add_expr bv e) lblel;
-      add_opt add_expr bv opte
-  | Pexp_field(e, fld) -> add_expr bv e; add bv fld
-  | Pexp_setfield(e1, fld, e2) -> add_expr bv e1; add bv fld; add_expr bv e2
-  | Pexp_array el -> List.iter (add_expr bv) el
-  | Pexp_ifthenelse(e1, e2, opte3) ->
-      add_expr bv e1; add_expr bv e2; add_opt add_expr bv opte3
-  | Pexp_sequence(e1, e2) -> add_expr bv e1; add_expr bv e2
-  | Pexp_while(e1, e2) -> add_expr bv e1; add_expr bv e2
-  | Pexp_for( _, e1, e2, _, e3) ->
-      add_expr bv e1; add_expr bv e2; add_expr bv e3
-  | Pexp_coerce(e1, oty2, ty3) ->
-      add_expr bv e1;
-      add_opt add_type bv oty2;
-      add_type bv ty3
-  | Pexp_constraint(e1, ty2) ->
-      add_expr bv e1;
-      add_type bv ty2
-  | Pexp_send(e, _m) -> add_expr bv e
-  | Pexp_new li -> add bv li
-  | Pexp_setinstvar(_v, e) -> add_expr bv e
-  | Pexp_override sel -> List.iter (fun (_s, e) -> add_expr bv e) sel
-  | Pexp_letmodule(id, m, e) ->
-      let b = add_module_binding bv m in
-      add_expr (StringMap.add id.txt b bv) e
-  | Pexp_assert (e) -> add_expr bv e
-  | Pexp_lazy (e) -> add_expr bv e
-  | Pexp_poly (e, t) -> add_expr bv e; add_opt add_type bv t
-  | Pexp_object { pcstr_self = pat; pcstr_fields = fieldl } ->
-      let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl
-  | Pexp_newtype (_, e) -> add_expr bv e
-  | Pexp_pack m -> add_module bv m
-  | Pexp_open (_ovf, m, e) ->
-      let bv = open_module bv m.txt in add_expr bv e
-  | Pexp_extension (({ txt = ("ocaml.extension_constructor"|
-                              "extension_constructor"); _ },
-                     PStr [item]) as e) ->
-      begin match item.pstr_desc with
-      | Pstr_eval ({ pexp_desc = Pexp_construct (c, None) }, _) -> add bv c
-      | _ -> handle_extension e
-      end
-  | Pexp_extension e -> handle_extension e
-  | Pexp_unreachable -> ()
-
-and add_cases bv cases =
-  List.iter (add_case bv) cases
-
-and add_case bv {pc_lhs; pc_guard; pc_rhs} =
-  let bv = add_pattern bv pc_lhs in
-  add_opt add_expr bv pc_guard;
-  add_expr bv pc_rhs
-
-and add_bindings recf bv pel =
-  let bv' = List.fold_left (fun bv x -> add_pattern bv x.pvb_pat) bv pel in
-  let bv = if recf = Recursive then bv' else bv in
-  List.iter (fun x -> add_expr bv x.pvb_expr) pel;
-  bv'
-
-and add_modtype bv mty =
-  match mty.pmty_desc with
-    Pmty_ident l -> add bv l
-  | Pmty_alias l -> addmodule bv l
-  | Pmty_signature s -> add_signature bv s
-  | Pmty_functor(id, mty1, mty2) ->
-      Misc.may (add_modtype bv) mty1;
-      add_modtype (StringMap.add id.txt bound bv) mty2
-  | Pmty_with(mty, cstrl) ->
-      add_modtype bv mty;
-      List.iter
-        (function
-          | Pwith_type (_, td) -> add_type_declaration bv td
-          | Pwith_module (_, lid) -> addmodule bv lid
-          | Pwith_typesubst td -> add_type_declaration bv td
-          | Pwith_modsubst (_, lid) -> addmodule bv lid
-        )
-        cstrl
-  | Pmty_typeof m -> add_module bv m
-  | Pmty_extension e -> handle_extension e
-
-and add_module_alias bv l =
-  try
-    add_parent bv l;
-    lookup_map l.txt bv
-  with Not_found ->
-    match l.txt with
-      Lident s -> make_leaf s
-    | _ -> addmodule bv l; bound (* cannot delay *)
-
-and add_modtype_binding bv mty =
-  if not !Clflags.transparent_modules then add_modtype bv mty;
-  match mty.pmty_desc with
-    Pmty_alias l ->
-      add_module_alias bv l
-  | Pmty_signature s ->
-      make_node (add_signature_binding bv s)
-  | Pmty_typeof modl ->
-      add_module_binding bv modl
-  | _ ->
-      if !Clflags.transparent_modules then add_modtype bv mty; bound
-
-and add_signature bv sg =
-  ignore (add_signature_binding bv sg)
-
-and add_signature_binding bv sg =
-  snd (List.fold_left add_sig_item (bv, StringMap.empty) sg)
-
-and add_sig_item (bv, m) item =
-  match item.psig_desc with
-    Psig_value vd ->
-      add_type bv vd.pval_type; (bv, m)
-  | Psig_type (_, dcls) ->
-      List.iter (add_type_declaration bv) dcls; (bv, m)
-  | Psig_typext te ->
-      add_type_extension bv te; (bv, m)
-  | Psig_exception pext ->
-      add_extension_constructor bv pext; (bv, m)
-  | Psig_module pmd ->
-      let m' = add_modtype_binding bv pmd.pmd_type in
-      let add = StringMap.add pmd.pmd_name.txt m' in
-      (add bv, add m)
-  | Psig_recmodule decls ->
-      let add =
-        List.fold_right (fun pmd -> StringMap.add pmd.pmd_name.txt bound)
-                        decls
-      in
-      let bv' = add bv and m' = add m in
-      List.iter (fun pmd -> add_modtype bv' pmd.pmd_type) decls;
-      (bv', m')
-  | Psig_modtype x ->
-      begin match x.pmtd_type with
-        None -> ()
-      | Some mty -> add_modtype bv mty
-      end;
-      (bv, m)
-  | Psig_open od ->
-      (open_module bv od.popen_lid.txt, m)
-  | Psig_include incl ->
-      let Node (s, m') = add_modtype_binding bv incl.pincl_mod in
-      add_names s;
-      let add = StringMap.fold StringMap.add m' in
-      (add bv, add m)
-  | Psig_class cdl ->
-      List.iter (add_class_description bv) cdl; (bv, m)
-  | Psig_class_type cdtl ->
-      List.iter (add_class_type_declaration bv) cdtl; (bv, m)
-  | Psig_attribute _ -> (bv, m)
-  | Psig_extension (e, _) ->
-      handle_extension e;
-      (bv, m)
-
-and add_module_binding bv modl =
-  if not !Clflags.transparent_modules then add_module bv modl;
-  match modl.pmod_desc with
-    Pmod_ident l ->
-      begin try
-        add_parent bv l;
-        lookup_map l.txt bv
-      with Not_found ->
-        match l.txt with
-          Lident s -> make_leaf s
-        | _ ->  addmodule bv l; bound
-      end
-  | Pmod_structure s ->
-      make_node (snd (add_structure_binding bv s))
-  | _ ->
-      if !Clflags.transparent_modules then add_module bv modl; bound
-
-and add_module bv modl =
-  match modl.pmod_desc with
-    Pmod_ident l -> addmodule bv l
-  | Pmod_structure s -> ignore (add_structure bv s)
-  | Pmod_functor(id, mty, modl) ->
-      Misc.may (add_modtype bv) mty;
-      add_module (StringMap.add id.txt bound bv) modl
-  | Pmod_apply(mod1, mod2) ->
-      add_module bv mod1; add_module bv mod2
-  | Pmod_constraint(modl, mty) ->
-      add_module bv modl; add_modtype bv mty
-  | Pmod_unpack(e) ->
-      add_expr bv e
-  | Pmod_extension e ->
-      handle_extension e
-
-and add_structure bv item_list =
-  let (bv, m) = add_structure_binding bv item_list in
-  add_names (collect_free (make_node m));
-  bv
-
-and add_structure_binding bv item_list =
-  List.fold_left add_struct_item (bv, StringMap.empty) item_list
-
-and add_struct_item (bv, m) item : _ StringMap.t * _ StringMap.t =
-  match item.pstr_desc with
-    Pstr_eval (e, _attrs) ->
-      add_expr bv e; (bv, m)
-  | Pstr_value(rf, pel) ->
-      let bv = add_bindings rf bv pel in (bv, m)
-  | Pstr_primitive vd ->
-      add_type bv vd.pval_type; (bv, m)
-  | Pstr_type (_, dcls) ->
-      List.iter (add_type_declaration bv) dcls; (bv, m)
-  | Pstr_typext te ->
-      add_type_extension bv te;
-      (bv, m)
-  | Pstr_exception pext ->
-      add_extension_constructor bv pext; (bv, m)
-  | Pstr_module x ->
-      let b = add_module_binding bv x.pmb_expr in
-      let add = StringMap.add x.pmb_name.txt b in
-      (add bv, add m)
-  | Pstr_recmodule bindings ->
-      let add =
-        List.fold_right (fun x -> StringMap.add x.pmb_name.txt bound) bindings
-      in
-      let bv' = add bv and m = add m in
-      List.iter
-        (fun x -> add_module bv' x.pmb_expr)
-        bindings;
-      (bv', m)
-  | Pstr_modtype x ->
-      begin match x.pmtd_type with
-        None -> ()
-      | Some mty -> add_modtype bv mty
-      end;
-      (bv, m)
-  | Pstr_open od ->
-      (open_module bv od.popen_lid.txt, m)
-  | Pstr_class cdl ->
-      List.iter (add_class_declaration bv) cdl; (bv, m)
-  | Pstr_class_type cdtl ->
-      List.iter (add_class_type_declaration bv) cdtl; (bv, m)
-  | Pstr_include incl ->
-      let Node (s, m') = add_module_binding bv incl.pincl_mod in
-      add_names s;
-      let add = StringMap.fold StringMap.add m' in
-      (add bv, add m)
-  | Pstr_attribute _ -> (bv, m)
-  | Pstr_extension (e, _) ->
-      handle_extension e;
-      (bv, m)
-
-and add_use_file bv top_phrs =
-  ignore (List.fold_left add_top_phrase bv top_phrs)
-
-and add_implementation bv l =
-  if !Clflags.transparent_modules then
-    ignore (add_structure_binding bv l)
-  else ignore (add_structure bv l)
-
-and add_implementation_binding bv l =
-  snd (add_structure_binding bv l)
-
-and add_top_phrase bv = function
-  | Ptop_def str -> add_structure bv str
-  | Ptop_dir (_, _) -> bv
-
-and add_class_expr bv ce =
-  match ce.pcl_desc with
-    Pcl_constr(l, tyl) ->
-      add bv l; List.iter (add_type bv) tyl
-  | Pcl_structure { pcstr_self = pat; pcstr_fields = fieldl } ->
-      let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl
-  | Pcl_fun(_, opte, pat, ce) ->
-      add_opt add_expr bv opte;
-      let bv = add_pattern bv pat in add_class_expr bv ce
-  | Pcl_apply(ce, exprl) ->
-      add_class_expr bv ce; List.iter (fun (_,e) -> add_expr bv e) exprl
-  | Pcl_let(rf, pel, ce) ->
-      let bv = add_bindings rf bv pel in add_class_expr bv ce
-  | Pcl_constraint(ce, ct) ->
-      add_class_expr bv ce; add_class_type bv ct
-  | Pcl_extension e -> handle_extension e
-
-and add_class_field bv pcf =
-  match pcf.pcf_desc with
-    Pcf_inherit(_, ce, _) -> add_class_expr bv ce
-  | Pcf_val(_, _, Cfk_concrete (_, e))
-  | Pcf_method(_, _, Cfk_concrete (_, e)) -> add_expr bv e
-  | Pcf_val(_, _, Cfk_virtual ty)
-  | Pcf_method(_, _, Cfk_virtual ty) -> add_type bv ty
-  | Pcf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2
-  | Pcf_initializer e -> add_expr bv e
-  | Pcf_attribute _ -> ()
-  | Pcf_extension e -> handle_extension e
-
-and add_class_declaration bv decl =
-  add_class_expr bv decl.pci_expr
diff --git a/tools/depend.mli b/tools/depend.mli
deleted file mode 100644
index e34abbe7..00000000
--- a/tools/depend.mli
+++ /dev/null
@@ -1,38 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(** Module dependencies. *)
-
-module StringSet : Set.S with type elt = string
-module StringMap : Map.S with type key = string
-
-type map_tree = Node of StringSet.t * bound_map
-and  bound_map = map_tree StringMap.t
-val make_leaf : string -> map_tree
-val make_node : bound_map -> map_tree
-val weaken_map : StringSet.t -> map_tree -> map_tree
-
-val free_structure_names : StringSet.t ref
-
-val open_module : bound_map -> Longident.t -> bound_map
-
-val add_use_file : bound_map -> Parsetree.toplevel_phrase list -> unit
-
-val add_signature : bound_map -> Parsetree.signature -> unit
-
-val add_implementation : bound_map -> Parsetree.structure -> unit
-
-val add_implementation_binding : bound_map -> Parsetree.structure -> bound_map
-val add_signature_binding : bound_map -> Parsetree.signature -> bound_map
diff --git a/tools/dumpobj.ml b/tools/dumpobj.ml
index 3c462e67..e4c8186c 100644
--- a/tools/dumpobj.ml
+++ b/tools/dumpobj.ml
@@ -26,6 +26,7 @@ open Cmo_format
 open Printf
 
 let print_locations = ref true
+let print_reloc_info = ref false
 
 (* Read signed and unsigned integers *)
 
@@ -497,6 +498,8 @@ let dump_obj ic =
   seek_in ic cu_pos;
   let cu = (input_value ic : compilation_unit) in
   reloc := cu.cu_reloc;
+  if !print_reloc_info then
+    List.iter print_reloc cu.cu_reloc;
   if cu.cu_debug > 0 then begin
     seek_in ic cu.cu_debug;
     let evl = (input_value ic : debug_event list) in
@@ -510,13 +513,7 @@ let dump_obj ic =
 
 let read_primitive_table ic len =
   let p = really_input_string ic len in
-  let rec split beg cur =
-    if cur >= len then []
-    else if p.[cur] = '\000' then
-      String.sub p beg (cur - beg) :: split (cur + 1) (cur + 1)
-    else
-      split beg (cur + 1) in
-  Array.of_list(split 0 0)
+  String.split_on_char '\000' p |> List.filter ((<>) "") |> Array.of_list
 
 (* Print an executable file *)
 
@@ -549,6 +546,7 @@ let dump_exe ic =
 
 let arg_list = [
   "-noloc", Arg.Clear print_locations, " : don't print source information";
+  "-reloc", Arg.Set print_reloc_info, " : print relocation information";
 ]
 let arg_usage =
   Printf.sprintf "%s [OPTIONS] FILES : dump content of bytecode files"
diff --git a/tools/lexer299.mll b/tools/lexer299.mll
index 6ff82a89..13453999 100644
--- a/tools/lexer299.mll
+++ b/tools/lexer299.mll
@@ -58,6 +58,7 @@ type token =
   | GREATER
   | GREATERRBRACE
   | GREATERRBRACKET
+  | HASH
   | IF
   | IN
   | INCLUDE
@@ -104,7 +105,6 @@ type token =
   | RPAREN
   | SEMI
   | SEMISEMI
-  | SHARP
   | SIG
   | STAR
   | STRING of (string)
@@ -345,7 +345,7 @@ rule token = parse
   | "#" [' ' '\t']* ['0'-'9']+ [^ '\n' '\r'] * ('\n' | '\r' | "\r\n")
       (* # linenum ...  *)
       { token lexbuf }
-  | "#"  { SHARP }
+  | "#"  { HASH }
   | "&"  { AMPERSAND }
   | "&&" { AMPERAMPER }
   | "`"  { BACKQUOTE }
diff --git a/tools/lexer301.mll b/tools/lexer301.mll
index 3823952e..e574c365 100644
--- a/tools/lexer301.mll
+++ b/tools/lexer301.mll
@@ -57,6 +57,7 @@ type token =
   | GREATER
   | GREATERRBRACE
   | GREATERRBRACKET
+  | HASH
   | IF
   | IN
   | INCLUDE
@@ -106,7 +107,6 @@ type token =
   | RPAREN
   | SEMI
   | SEMISEMI
-  | SHARP
   | SIG
   | STAR
   | STRING of (string)
@@ -346,7 +346,7 @@ rule token = parse
   | "#" [' ' '\t']* ['0'-'9']+ [^ '\n' '\r'] * ('\n' | '\r' | "\r\n")
       (* # linenum ...  *)
       { token lexbuf }
-  | "#"  { SHARP }
+  | "#"  { HASH }
   | "&"  { AMPERSAND }
   | "&&" { AMPERAMPER }
   | "`"  { BACKQUOTE }
diff --git a/tools/objinfo.ml b/tools/objinfo.ml
index 30bc353d..924f61fe 100644
--- a/tools/objinfo.ml
+++ b/tools/objinfo.ml
@@ -49,10 +49,15 @@ let print_name_crc (name, crco) =
 let print_line name =
   printf "\t%s\n" name
 
+let print_required_global id =
+  printf "\t%s\n" (Ident.name id)
+
 let print_cmo_infos cu =
   printf "Unit name: %s\n" cu.cu_name;
   print_string "Interfaces imported:\n";
   List.iter print_name_crc cu.cu_imports;
+  print_string "Required globals:\n";
+  List.iter print_required_global cu.cu_required_globals;
   printf "Uses unsafe features: ";
   (match cu.cu_primitives with
     | [] -> printf "no\n"
diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml
index 5508b179..22d1e29a 100644
--- a/tools/ocamlcp.ml
+++ b/tools/ocamlcp.ml
@@ -86,6 +86,7 @@ module Options = Main_args.Make_bytecomp_options (struct
   let _output_obj = option "-output-obj"
   let _output_complete_obj = option "-output-complete-obj"
   let _pack = option "-pack"
+  let _plugin = option_with_arg "-plugin"
   let _pp _s = incompatible "-pp"
   let _ppx _s = incompatible "-ppx"
   let _principal = option "-principal"
@@ -101,6 +102,8 @@ module Options = Main_args.Make_bytecomp_options (struct
   let _no_strict_formats = option "-no-strict-formats"
   let _thread () = option "-thread" ()
   let _vmthread () = option "-vmthread" ()
+  let _unboxed_types = option "-unboxed-types"
+  let _no_unboxed_types = option "-no-unboxed-types"
   let _unsafe = option "-unsafe"
   let _unsafe_string = option "-unsafe-string"
   let _use_prims s = option_with_arg "-use-prims" s
diff --git a/tools/ocamldep.ml b/tools/ocamldep.ml
index 6e102e9b..4fd3f1cf 100644
--- a/tools/ocamldep.ml
+++ b/tools/ocamldep.ml
@@ -26,6 +26,7 @@ let load_path = ref ([] : (string * string array) list)
 let ml_synonyms = ref [".ml"]
 let mli_synonyms = ref [".mli"]
 let native_only = ref false
+let bytecode_only = ref false
 let error_occurred = ref false
 let raw_dependencies = ref false
 let sort_files = ref false
@@ -279,21 +280,21 @@ let read_and_approximate inputfile =
     report_err exn;
     !Depend.free_structure_names
 
-let read_parse_and_extract parse_function extract_function def magic
-    source_file =
+let read_parse_and_extract parse_function extract_function def ast_kind
+                           source_file =
   Depend.free_structure_names := Depend.StringSet.empty;
   try
     let input_file = Pparse.preprocess source_file in
     begin try
       let ast =
         Pparse.file ~tool_name Format.err_formatter
-                    input_file parse_function magic
+                    input_file parse_function ast_kind
       in
       let bound_vars =
         List.fold_left
           (fun bv modname ->
             Depend.open_module bv (Longident.Lident modname))
-          !module_map !Clflags.open_modules
+          !module_map ((* PR#7248 *) List.rev !Clflags.open_modules)
       in
       let r = extract_function bound_vars ast in
       Pparse.remove_preprocessed input_file;
@@ -309,6 +310,46 @@ let read_parse_and_extract parse_function extract_function def magic
     else (read_and_approximate source_file, def)
   end
 
+let print_ml_dependencies source_file extracted_deps =
+  let basename = Filename.chop_extension source_file in
+  let byte_targets = [ basename ^ ".cmo" ] in
+  let native_targets =
+    if !all_dependencies
+    then [ basename ^ ".cmx"; basename ^ ".o" ]
+    else [ basename ^ ".cmx" ] in
+  let init_deps = if !all_dependencies then [source_file] else [] in
+  let cmi_name = basename ^ ".cmi" in
+  let init_deps, extra_targets =
+    if List.exists (fun ext -> Sys.file_exists (basename ^ ext))
+        !mli_synonyms
+    then (cmi_name :: init_deps, cmi_name :: init_deps), []
+    else (init_deps, init_deps),
+         (if !all_dependencies then [cmi_name] else [])
+  in
+  let (byt_deps, native_deps) =
+    Depend.StringSet.fold (find_dependency ML)
+      extracted_deps init_deps in
+  if not !native_only then
+    print_dependencies (byte_targets @ extra_targets) byt_deps;
+  if not !bytecode_only then
+    print_dependencies (native_targets @ extra_targets) native_deps
+
+let print_mli_dependencies source_file extracted_deps =
+  let basename = Filename.chop_extension source_file in
+  let (byt_deps, _opt_deps) =
+    Depend.StringSet.fold (find_dependency MLI)
+      extracted_deps ([], []) in
+  print_dependencies [basename ^ ".cmi"] byt_deps
+
+let print_file_dependencies (source_file, kind, extracted_deps) =
+  if !raw_dependencies then begin
+    print_raw_dependencies source_file extracted_deps
+  end else
+    match kind with
+    | ML -> print_ml_dependencies source_file extracted_deps
+    | MLI -> print_mli_dependencies source_file extracted_deps
+
+
 let ml_file_dependencies source_file =
   let parse_use_file_as_impl lexbuf =
     let f x =
@@ -320,54 +361,16 @@ let ml_file_dependencies source_file =
   in
   let (extracted_deps, ()) =
     read_parse_and_extract parse_use_file_as_impl Depend.add_implementation ()
-                           Config.ast_impl_magic_number source_file
+                           Pparse.Structure source_file
   in
-  if !sort_files then
-    files := (source_file, ML, !Depend.free_structure_names) :: !files
-  else
-    if !raw_dependencies then begin
-      print_raw_dependencies source_file extracted_deps
-    end else begin
-      let basename = Filename.chop_extension source_file in
-      let byte_targets = [ basename ^ ".cmo" ] in
-      let native_targets =
-        if !all_dependencies
-        then [ basename ^ ".cmx"; basename ^ ".o" ]
-        else [ basename ^ ".cmx" ] in
-      let init_deps = if !all_dependencies then [source_file] else [] in
-      let cmi_name = basename ^ ".cmi" in
-      let init_deps, extra_targets =
-        if List.exists (fun ext -> Sys.file_exists (basename ^ ext))
-                       !mli_synonyms
-        then (cmi_name :: init_deps, cmi_name :: init_deps), []
-        else (init_deps, init_deps),
-             (if !all_dependencies then [cmi_name] else [])
-      in
-      let (byt_deps, native_deps) =
-        Depend.StringSet.fold (find_dependency ML)
-          extracted_deps init_deps in
-      if not !native_only then
-        print_dependencies (byte_targets @ extra_targets) byt_deps;
-      print_dependencies (native_targets @ extra_targets) native_deps;
-    end
+  files := (source_file, ML, extracted_deps) :: !files
 
 let mli_file_dependencies source_file =
   let (extracted_deps, ()) =
     read_parse_and_extract Parse.interface Depend.add_signature ()
-                           Config.ast_intf_magic_number source_file
+                           Pparse.Signature source_file
   in
-  if !sort_files then
-    files := (source_file, MLI, extracted_deps) :: !files
-  else
-    if !raw_dependencies then begin
-      print_raw_dependencies source_file extracted_deps
-    end else begin
-      let basename = Filename.chop_extension source_file in
-      let (byt_deps, _opt_deps) =
-        Depend.StringSet.fold (find_dependency MLI)
-          extracted_deps ([], []) in
-      print_dependencies [basename ^ ".cmi"] byt_deps
-    end
+  files := (source_file, MLI, extracted_deps) :: !files
 
 let process_file_as process_fun def source_file =
   Compenv.readenv ppf (Before_compile source_file);
@@ -493,11 +496,11 @@ let rec dump_map s0 ppf m =
 
 let process_ml_map =
   read_parse_and_extract Parse.implementation Depend.add_implementation_binding
-                         StringMap.empty Config.ast_impl_magic_number
+                         StringMap.empty Pparse.Structure
 
 let process_mli_map =
   read_parse_and_extract Parse.interface Depend.add_signature_binding
-                         StringMap.empty Config.ast_intf_magic_number
+                         StringMap.empty Pparse.Signature
 
 let parse_map fname =
   map_files := fname :: !map_files ;
@@ -571,6 +574,8 @@ let _ =
         " Print module dependencies in raw form (not suitable for make)";
      "-native", Arg.Set native_only,
         " Generate dependencies for native-code only (no .cmo files)";
+     "-bytecode", Arg.Set bytecode_only,
+        " Generate dependencies for bytecode-code only (no .cmx files)";
      "-one-line", Arg.Set one_line,
         " Output one line per file, regardless of the length";
      "-open", Arg.String (add_to_list Clflags.open_modules),
@@ -589,5 +594,6 @@ let _ =
          " Print version number and exit";
     ] file_dependencies usage;
   Compenv.readenv ppf Before_link;
-  if !sort_files then sort_files_by_dependencies !files;
+  if !sort_files then sort_files_by_dependencies !files
+  else List.iter print_file_dependencies (List.sort compare !files);
   exit (if !error_occurred then 2 else 0)
diff --git a/tools/ocamlmktop.ml b/tools/ocamlmktop.ml
index 30b9d50b..ab333966 100644
--- a/tools/ocamlmktop.ml
+++ b/tools/ocamlmktop.ml
@@ -15,6 +15,18 @@
 
 let _ =
   let args = Ccomp.quote_files (List.tl (Array.to_list Sys.argv)) in
-  exit(Sys.command("ocamlc -I +compiler-libs -linkall ocamlcommon.cma \
-                    ocamlbytecomp.cma ocamltoplevel.cma "
-                   ^ args ^ " topstart.cmo"))
+  let ocamlmktop = Sys.executable_name in
+  (* On Windows Sys.command calls system() which in turn calls 'cmd.exe /c'.
+     cmd.exe has special quoting rules (see 'cmd.exe /?' for details).
+     Short version: if the string passed to cmd.exe starts with '"',
+     the first and last '"' are removed *)
+  let ocamlc,extra_quote =
+    if Sys.win32 then "ocamlc.exe","\"" else "ocamlc",""
+  in
+  let ocamlc = Filename.(quote (concat (dirname ocamlmktop) ocamlc)) in
+  let cmdline =
+    extra_quote ^ ocamlc ^ " -I +compiler-libs -linkall ocamlcommon.cma " ^
+    "ocamlbytecomp.cma ocamltoplevel.cma " ^ args ^ " topstart.cmo" ^
+    extra_quote
+  in
+  exit(Sys.command cmdline)
diff --git a/tools/ocamlmktop.tpl b/tools/ocamlmktop.tpl
deleted file mode 100644
index f9d9fae1..00000000
--- a/tools/ocamlmktop.tpl
+++ /dev/null
@@ -1,18 +0,0 @@
-#!/bin/sh
-#**************************************************************************
-#*                                                                        *
-#*                                 OCaml                                  *
-#*                                                                        *
-#*            Damien Doligez, projet Para, INRIA Rocquencourt             *
-#*                                                                        *
-#*   Copyright 1999 Institut National de Recherche en Informatique et     *
-#*     en Automatique.                                                    *
-#*                                                                        *
-#*   All rights reserved.  This file is distributed under the terms of    *
-#*   the GNU Lesser General Public License version 2.1, with the          *
-#*   special exception on linking described in the file LICENSE.          *
-#*                                                                        *
-#**************************************************************************
-
-exec %%BINDIR%%/ocamlc -I +compiler-libs -linkall ocamlcommon.cma \
-                       ocamlbytecomp.cma ocamltoplevel.cma "$@" topstart.cmo
diff --git a/tools/ocamloptp.ml b/tools/ocamloptp.ml
index b96d2834..188674af 100644
--- a/tools/ocamloptp.ml
+++ b/tools/ocamloptp.ml
@@ -108,6 +108,7 @@ module Options = Main_args.Make_optcomp_options (struct
   let _output_complete_obj = option "-output-complete-obj"
   let _p = option "-p"
   let _pack = option "-pack"
+  let _plugin = option_with_arg "-plugin"
   let _pp _s = incompatible "-pp"
   let _ppx _s = incompatible "-ppx"
   let _principal = option "-principal"
@@ -127,6 +128,8 @@ module Options = Main_args.Make_optcomp_options (struct
   let _thread = option "-thread"
   let _unbox_closures = option "-unbox-closures"
   let _unbox_closures_factor = option_with_int "-unbox-closures"
+  let _unboxed_types = option "-unboxed-types"
+  let _no_unboxed_types = option "-no-unboxed-types"
   let _unsafe = option "-unsafe"
   let _unsafe_string = option "-unsafe-string"
   let _v = option "-v"
diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml
index 68e7d9b0..0a22fa46 100644
--- a/tools/ocamlprof.ml
+++ b/tools/ocamlprof.ml
@@ -284,6 +284,9 @@ and rw_exp iflag sexp =
       rewrite_mod iflag smod;
       rewrite_exp iflag sexp
 
+  | Pexp_letexception (_cd, exp) ->
+      rewrite_exp iflag exp
+
   | Pexp_assert (cond) -> rewrite_exp iflag cond
 
   | Pexp_lazy (expr) -> rewrite_exp iflag expr
diff --git a/tools/primreq.ml b/tools/primreq.ml
index fc7dcf22..bef375fc 100644
--- a/tools/primreq.ml
+++ b/tools/primreq.ml
@@ -40,8 +40,7 @@ let scan_info cu =
 
 let scan_obj filename =
   let ic = open_in_bin filename in
-  let buffer = String.create (String.length cmo_magic_number) in
-  really_input ic buffer 0 (String.length cmo_magic_number);
+  let buffer = really_input_string ic (String.length cmo_magic_number) in
   if buffer = cmo_magic_number then begin
     let cu_pos = input_binary_int ic in
     seek_in ic cu_pos;
diff --git a/toplevel/expunge.ml b/toplevel/expunge.ml
index 47c370d8..e97d8e59 100644
--- a/toplevel/expunge.ml
+++ b/toplevel/expunge.ml
@@ -41,7 +41,7 @@ let expunge_map tbl =
   Symtable.filter_global_map (fun id -> keep (Ident.name id)) tbl
 
 let expunge_crcs tbl =
-  List.filter (fun (unit, crc) -> keep unit) tbl
+  List.filter (fun (unit, _crc) -> keep unit) tbl
 
 let main () =
   let input_name = Sys.argv.(1) in
diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml
index dc7c8d88..28682a9d 100644
--- a/toplevel/genprintval.ml
+++ b/toplevel/genprintval.ml
@@ -77,7 +77,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
         let hash x =
           try
             Hashtbl.hash x
-          with exn -> 0
+          with _exn -> 0
       end)
 
 
@@ -159,7 +159,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
 
     let install_printer path ty fn =
       let print_val ppf obj =
-        try fn ppf obj with exn -> exn_printer ppf path in
+        try fn ppf obj with _exn -> exn_printer ppf path in
       let printer obj = Oval_printer (fun ppf -> print_val ppf obj) in
       printers := (path, Simple (ty, printer)) :: !printers
 
@@ -196,9 +196,9 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
 
     let tree_of_qualified lookup_fun env ty_path name =
       match ty_path with
-      | Pident id ->
+      | Pident _ ->
           Oide_ident name
-      | Pdot(p, s, pos) ->
+      | Pdot(p, _s, _pos) ->
           if try
                match (lookup_fun (Lident name) env).desc with
                | Tconstr(ty_path', _, _) -> Path.same ty_path ty_path'
@@ -206,7 +206,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
              with Not_found -> false
           then Oide_ident name
           else Oide_dot (Printtyp.tree_of_path p, name)
-      | Papply(p1, p2) ->
+      | Papply _ ->
           Printtyp.tree_of_path ty_path
 
     let tree_of_constr =
@@ -255,7 +255,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
           match (Ctype.repr ty).desc with
           | Tvar _ | Tunivar _ ->
               Oval_stuff ""
-          | Tarrow(_, ty1, ty2, _) ->
+          | Tarrow _ ->
               Oval_stuff ""
           | Ttuple(ty_list) ->
               Oval_tuple (tree_of_val_list 0 depth obj ty_list)
@@ -365,9 +365,11 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
                     tree_of_val depth obj
                       (try Ctype.apply env decl.type_params body ty_list with
                          Ctype.Cannot_apply -> abstract_type)
-                | {type_kind = Type_variant constr_list} ->
+                | {type_kind = Type_variant constr_list; type_unboxed} ->
+                    let unbx = type_unboxed.unboxed in
                     let tag =
-                      if O.is_block obj
+                      if unbx then Cstr_unboxed
+                      else if O.is_block obj
                       then Cstr_block(O.tag obj)
                       else Cstr_constant(O.obj obj) in
                     let {cd_id;cd_args;cd_res} =
@@ -393,12 +395,12 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
                           in
                           tree_of_constr_with_args (tree_of_constr env path)
                             (Ident.name cd_id) false 0 depth obj
-                            ty_args
+                            ty_args unbx
                       | Cstr_record lbls ->
                           let r =
                             tree_of_record_fields depth
                               env path type_params ty_list
-                              lbls 0 obj
+                              lbls 0 obj unbx
                           in
                           Oval_constr(tree_of_constr env path
                                         (Ident.name cd_id),
@@ -413,9 +415,12 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
                           | Record_extension -> 1
                           | _ -> 0
                         in
+                        let unbx =
+                          match rep with Record_unboxed _ -> true | _ -> false
+                        in
                         tree_of_record_fields depth
                           env path decl.type_params ty_list
-                          lbl_list pos obj
+                          lbl_list pos obj unbx
                     end
                 | {type_kind = Type_open} ->
                     tree_of_extension path depth obj
@@ -464,7 +469,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
         end
 
       and tree_of_record_fields depth env path type_params ty_list
-          lbl_list pos obj =
+          lbl_list pos obj unboxed =
         let rec tree_of_fields pos = function
           | [] -> []
           | {ld_id; ld_type} :: remainder ->
@@ -481,8 +486,9 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
                 if pos = 0 then tree_of_label env path name
                 else Oide_ident name
               and v =
-                nest tree_of_val (depth - 1) (O.field obj pos)
-                  ty_arg
+                if unboxed
+                then tree_of_val (depth - 1) obj ty_arg
+                else nest tree_of_val (depth - 1) (O.field obj pos) ty_arg
               in
               (lid, v) :: tree_of_fields (pos + 1) remainder
         in
@@ -497,10 +503,10 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
       tree_list start ty_list
 
       and tree_of_constr_with_args
-             tree_of_cstr cstr_name inlined start depth obj ty_args =
+             tree_of_cstr cstr_name inlined start depth obj ty_args unboxed =
         let lid = tree_of_cstr cstr_name in
         let args =
-          if inlined then
+          if inlined || unboxed then
             match ty_args with
             | [ty] -> [ tree_of_val (depth - 1) obj ty ]
             | _ -> assert false
@@ -533,7 +539,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
         tree_of_constr_with_args
            (fun x -> Oide_ident x) name (cstr.cstr_inlined <> None)
            1 depth bucket
-           cstr.cstr_args
+           cstr.cstr_args false
       with Not_found | EVP.Error ->
         match check_depth depth bucket ty with
           Some x -> x
@@ -545,15 +551,15 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
     and find_printer depth env ty =
       let rec find = function
       | [] -> raise Not_found
-      | (name, Simple (sch, printer)) :: remainder ->
+      | (_name, Simple (sch, printer)) :: remainder ->
           if Ctype.moregeneral env false sch ty
           then printer
           else find remainder
-      | (name, Generic (path, fn)) :: remainder ->
+      | (_name, Generic (path, fn)) :: remainder ->
           begin match (Ctype.expand_head env ty).desc with
           | Tconstr (p, args, _) when Path.same p path ->
               begin try apply_generic_printer path (fn depth) args
-              with _ -> (fun obj -> out_exn path) end
+              with _ -> (fun _obj -> out_exn path) end
           | _ -> find remainder end in
       find !printers
 
@@ -564,7 +570,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
           let printer = fn (fun depth obj -> tree_of_val depth obj arg) in
           apply_generic_printer path printer args
       | _ ->
-          (fun obj ->
+          (fun _obj ->
             let printer ppf =
               fprintf ppf ""
                 Printtyp.path path in
diff --git a/toplevel/opttopdirs.ml b/toplevel/opttopdirs.ml
index cb155ff0..795c7e48 100644
--- a/toplevel/opttopdirs.ml
+++ b/toplevel/opttopdirs.ml
@@ -81,11 +81,11 @@ let load_file ppf name0 =
       (* The Dynlink interface does not allow us to distinguish between
           a Dynlink.Error exceptions raised in the loaded modules
           or a genuine error during dynlink... *)
-      try Dynlink.loadfile fn; true
+      try Compdynlink.loadfile fn; true
       with
-      | Dynlink.Error err ->
+      | Compdynlink.Error err ->
         fprintf ppf "Error while loading %s: %s.@."
-          name (Dynlink.error_message err);
+          name (Compdynlink.error_message err);
         false
       | exn ->
         print_exception_outcome ppf exn;
@@ -111,9 +111,9 @@ type 'a printer_type_new = Format.formatter -> 'a -> unit
 type 'a printer_type_old = 'a -> unit
 
 let match_printer_type ppf desc typename =
-  let (printer_type, _) =
+  let printer_type =
     try
-      Env.lookup_type (Ldot(Lident "Topdirs", typename)) !toplevel_env
+      Env.lookup_type (Ldot(Lident "Opttopdirs", typename)) !toplevel_env
     with Not_found ->
       fprintf ppf "Cannot find type Topdirs.%s.@." typename;
       raise Exit in
@@ -151,7 +151,7 @@ let dir_install_printer ppf lid =
     let v = eval_path !toplevel_env path in
     let print_function =
       if is_old_style then
-        (fun formatter repr -> Obj.obj v (Obj.obj repr))
+        (fun _formatter repr -> Obj.obj v (Obj.obj repr))
       else
         (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in
     install_printer path ty_arg print_function
@@ -159,7 +159,7 @@ let dir_install_printer ppf lid =
 
 let dir_remove_printer ppf lid =
   try
-    let (ty_arg, path, is_old_style) = find_printer_type ppf lid in
+    let (_ty_arg, path, _is_old_style) = find_printer_type ppf lid in
     begin try
       remove_printer path
     with Not_found ->
diff --git a/toplevel/opttoploop.ml b/toplevel/opttoploop.ml
index 628aee7c..32e9905f 100644
--- a/toplevel/opttoploop.ml
+++ b/toplevel/opttoploop.ml
@@ -84,8 +84,12 @@ 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)
+    let glob =
+      Lprim (Pfield pos,
+             [Lprim (Pgetglobal glb, [], Location.none)],
+             Location.none)
+    in
+    Llet(Strict, Pgenval, id, glob, l)
   ) (free_variables lam) lam
 
 let toplevel_value id =
@@ -99,9 +103,9 @@ let rec eval_path = function
       if Ident.persistent id || Ident.global id
       then global_symbol id
       else toplevel_value id
-  | Pdot(p, s, pos) ->
+  | Pdot(p, _s, pos) ->
       Obj.field (eval_path p) pos
-  | Papply(p1, p2) ->
+  | Papply _ ->
       fatal_error "Toploop.eval_path"
 
 let eval_path env path =
@@ -205,9 +209,9 @@ module Backend = struct
 end
 let backend = (module Backend : Backend_intf.S)
 
-let load_lambda ppf ~module_ident lam size =
+let load_lambda ppf ~module_ident ~required_globals lam size =
   if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam;
-  let slam = Simplif.simplify_lambda lam in
+  let slam = Simplif.simplify_lambda "//toplevel//" lam in
   if !Clflags.dump_lambda then fprintf ppf "%a@." Printlambda.lambda slam;
 
   let dll =
@@ -218,10 +222,11 @@ let load_lambda ppf ~module_ident lam size =
   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 }
+      { Lambda.code=lam ; main_module_block_size=size;
+        module_ident; required_globals }
   else
     Asmgen.compile_implementation_flambda ~source_provenance:Timings.Toplevel
-      ~backend ~toplevel:need_symbol fn ppf
+      ~required_globals ~backend ~toplevel:need_symbol fn ppf
       (Middle_end.middle_end ppf
          ~source_provenance:Timings.Toplevel ~prefixname:"" ~backend ~size
          ~module_ident ~module_initializer:lam ~filename:"toplevel");
@@ -300,25 +305,26 @@ let execute_phrase print_outcome ppf phr =
       (* Why is this done? *)
       ignore (Includemod.signatures oldenv sg sg');
       Typecore.force_delayed_checks ();
-      let module_ident, res, size =
+      let module_ident, res, required_globals, size =
         if Config.flambda then
-          let ((module_ident, size), res) =
+          let { Lambda.module_ident; main_module_block_size = size;
+                required_globals; code = res } =
             Translmod.transl_implementation_flambda !phrase_name
               (str, Tcoerce_none)
           in
           remember module_ident 0 sg';
-          module_ident, close_phrase res, size
+          module_ident, close_phrase res, required_globals, size
         else
           let size, res = Translmod.transl_store_phrases !phrase_name str in
-          Ident.create_persistent !phrase_name, res, size
+          Ident.create_persistent !phrase_name, res, Ident.Set.empty, size
       in
       Warnings.check_fatal ();
       begin try
         toplevel_env := newenv;
-        let res = load_lambda ppf ~module_ident res size in
+        let res = load_lambda ppf ~required_globals ~module_ident res size in
         let out_phr =
           match res with
-          | Result v ->
+          | Result _ ->
               if Config.flambda then
                 (* CR-someday trefis: *)
                 ()
@@ -380,7 +386,7 @@ let execute_phrase print_outcome ppf phr =
                        dir_name;
                false
              end
-          | Directive_int f, Pdir_int (n, Some _) ->
+          | Directive_int _, Pdir_int (_, Some _) ->
               fprintf ppf "Wrong integer literal for directive `%s'.@."
                 dir_name;
               false
@@ -392,19 +398,6 @@ let execute_phrase print_outcome ppf phr =
               false
       end
 
-(* Temporary assignment to a reference *)
-
-let protect r newval body =
-  let oldval = !r in
-  try
-    r := newval;
-    let res = body() in
-    r := oldval;
-    res
-  with x ->
-    r := oldval;
-    raise x
-
 (* Read and execute commands from a file, or from stdin if [name] is "". *)
 
 let use_print_results = ref true
@@ -416,6 +409,9 @@ let preprocess_phrase ppf phr =
         let str =
           Pparse.apply_rewriters_str ~restore:true ~tool_name:"ocaml" str
         in
+        let str =
+          Pparse.ImplementationHooks.apply_hooks
+            { Misc.sourcefile = "//toplevel//" } str in
         Ptop_def str
     | phr -> phr
   in
@@ -437,9 +433,9 @@ let use_file ppf wrap_mod name =
     let lb = Lexing.from_channel ic in
     Location.init lb filename;
     (* Skip initial #! line if any *)
-    Lexer.skip_sharp_bang lb;
+    Lexer.skip_hash_bang lb;
     let success =
-      protect Location.input_name filename (fun () ->
+      protect_refs [ R (Location.input_name, filename) ] (fun () ->
         try
           List.iter
             (fun ph ->
@@ -462,7 +458,7 @@ let mod_use_file ppf name = use_file ppf true name
 let use_file ppf name = use_file ppf false name
 
 let use_silently ppf name =
-  protect use_print_results false (fun () -> use_file ppf name)
+  protect_refs [ R (use_print_results, false) ] (fun () -> use_file ppf name)
 
 (* Reading function for interactive use *)
 
@@ -514,7 +510,7 @@ let refill_lexbuf buffer len =
 
 let _ =
   Sys.interactive := true;
-  Dynlink.init ();
+  Compdynlink.init ();
   Compmisc.init_path true;
   Clflags.dlcode := true;
   ()
@@ -549,7 +545,8 @@ exception PPerror
 
 let loop ppf =
   Location.formatter_for_warnings := ppf;
-  fprintf ppf "        OCaml version %s - native toplevel@.@." Config.version;
+  if not !Clflags.noversion then
+    fprintf ppf "        OCaml version %s - native toplevel@.@." Config.version;
   initialize_toplevel_env ();
   let lb = Lexing.from_function refill_lexbuf in
   Location.init lb "//toplevel//";
@@ -578,6 +575,13 @@ let loop ppf =
 
 (* Execute a script.  If [name] is "", read the script from stdin. *)
 
+let override_sys_argv args =
+  let len = Array.length args in
+  if Array.length Sys.argv < len then invalid_arg "Toploop.override_sys_argv";
+  Array.blit args 0 Sys.argv 0 len;
+  Obj.truncate (Obj.repr Sys.argv) len;
+  Arg.current := 0
+
 let run_script ppf name args =
   let len = Array.length args in
   if Array.length Sys.argv < len then invalid_arg "Toploop.run_script";
diff --git a/toplevel/opttoploop.mli b/toplevel/opttoploop.mli
index 3ce4d191..f234b4f4 100644
--- a/toplevel/opttoploop.mli
+++ b/toplevel/opttoploop.mli
@@ -120,3 +120,13 @@ val read_interactive_input : (string -> bytes -> int -> int * bool) ref
 (* Hooks for initialization *)
 
 val toplevel_startup_hook : (unit -> unit) ref
+
+(* Misc *)
+
+val override_sys_argv : string array -> unit
+(* [override_sys_argv args] replaces the contents of [Sys.argv] by [args]
+   and reset [Arg.current] to [0].
+
+   This is called by [run_script] so that [Sys.argv] represents
+   "script.ml args..." instead of the full command line:
+   "ocamlrun unix.cma ... script.ml args...". *)
diff --git a/toplevel/opttopmain.ml b/toplevel/opttopmain.ml
index 2f1795e1..3f5c5c00 100644
--- a/toplevel/opttopmain.ml
+++ b/toplevel/opttopmain.ml
@@ -73,42 +73,53 @@ module Options = Main_args.Make_opttop_options (struct
   let _noinit = set noinit
   let _clambda_checks () = clambda_checks := true
   let _inline spec =
-    Float_arg_helper.parse spec ~update:inline_threshold
-      ~help_text:"Syntax: -inline  | =[,...]"
+    Float_arg_helper.parse spec
+      "Syntax: -inline  | =[,...]"
+      inline_threshold
   let _inline_indirect_cost spec =
-    Int_arg_helper.parse spec ~update:inline_indirect_cost
-      ~help_text:"Syntax: -inline-indirect-cost  | =[,...]"
+    Int_arg_helper.parse spec
+      "Syntax: -inline-indirect-cost  | =[,...]"
+      inline_indirect_cost
   let _inline_toplevel spec =
-    Int_arg_helper.parse spec ~update:inline_toplevel_threshold
-      ~help_text:"Syntax: -inline-toplevel  | =[,...]"
+    Int_arg_helper.parse spec
+      "Syntax: -inline-toplevel  | =[,...]"
+      inline_toplevel_threshold
   let _inlining_report () = inlining_report := true
   let _dump_pass pass = set_dumped_pass pass true
   let _rounds n = simplify_rounds := Some n
   let _inline_max_unroll spec =
-    Int_arg_helper.parse spec ~update:inline_max_unroll
-      ~help_text:"Syntax: -inline-max-unroll  | =[,...]"
+    Int_arg_helper.parse spec
+      "Syntax: -inline-max-unroll  | =[,...]"
+      inline_max_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  | =[,...]"
+    Int_arg_helper.parse spec
+      "Syntax: -inline-call-cost  | =[,...]"
+       inline_call_cost
   let _inline_alloc_cost spec =
-    Int_arg_helper.parse spec ~update:inline_alloc_cost
-      ~help_text:"Syntax: -inline-alloc-cost  | =[,...]"
+    Int_arg_helper.parse spec
+      "Syntax: -inline-alloc-cost  | =[,...]"
+      inline_alloc_cost
   let _inline_prim_cost spec =
-    Int_arg_helper.parse spec ~update:inline_prim_cost
-      ~help_text:"Syntax: -inline-prim-cost  | =[,...]"
+    Int_arg_helper.parse spec
+      "Syntax: -inline-prim-cost  | =[,...]"
+       inline_prim_cost
   let _inline_branch_cost spec =
-    Int_arg_helper.parse spec ~update:inline_branch_cost
-      ~help_text:"Syntax: -inline-branch-cost  | =[,...]"
+    Int_arg_helper.parse spec
+      "Syntax: -inline-branch-cost  | =[,...]"
+      inline_branch_cost
   let _inline_lifting_benefit spec =
-    Int_arg_helper.parse spec ~update:inline_lifting_benefit
-      ~help_text:"Syntax: -inline-lifting-benefit  | =[,...]"
+    Int_arg_helper.parse spec
+      "Syntax: -inline-lifting-benefit  | =[,...]"
+      inline_lifting_benefit
   let _inline_branch_factor spec =
-    Float_arg_helper.parse spec ~update:inline_branch_factor
-      ~help_text:"Syntax: -inline-branch-factor  | =[,...]"
+    Float_arg_helper.parse spec
+      "Syntax: -inline-branch-factor  | =[,...]"
+      inline_branch_factor
   let _inline_max_depth spec =
-    Int_arg_helper.parse spec ~update:inline_max_depth
-      ~help_text:"Syntax: -inline-max-depth  | =[,...]"
+    Int_arg_helper.parse spec
+      "Syntax: -inline-max-depth  | =[,...]"
+      inline_max_depth
   let _no_unbox_free_vars_of_closures = clear unbox_free_vars_of_closures
   let _no_unbox_specialised_args = clear unbox_specialised_args
   let _o s = output_name := Some s
@@ -156,9 +167,13 @@ module Options = Main_args.Make_opttop_options (struct
   let _S = set keep_asm_file
   let _short_paths = clear real_paths
   let _stdin () = file_argument ""
+  let _unboxed_types = set unboxed_types
+  let _no_unboxed_types = clear unboxed_types
   let _unsafe = set fast
+  let _verbose = set verbose
   let _version () = print_version ()
   let _vnum () = print_version_num ()
+  let _no_version = set noversion
   let _w s = Warnings.parse_options false s
   let _warn_error s = Warnings.parse_options true s
   let _warn_help = Warnings.help_warnings
@@ -187,6 +202,7 @@ module Options = Main_args.Make_opttop_options (struct
   let _safe_string = clear unsafe_string
   let _unsafe_string = set unsafe_string
   let _open s = open_modules := s :: !open_modules
+  let _plugin p = Compplugin.load p
 
   let anonymous = file_argument
 end);;
diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml
index 7cce1987..a28ee990 100644
--- a/toplevel/topdirs.ml
+++ b/toplevel/topdirs.ml
@@ -281,7 +281,7 @@ type 'a printer_type_new = Format.formatter -> 'a -> unit
 type 'a printer_type_old = 'a -> unit
 
 let printer_type ppf typename =
-  let (printer_type, _) =
+  let printer_type =
     try
       Env.lookup_type (Ldot(Lident "Topdirs", typename)) !toplevel_env
     with Not_found ->
@@ -289,7 +289,7 @@ let printer_type ppf typename =
       raise Exit in
   printer_type
 
-let match_simple_printer_type ppf desc printer_type =
+let match_simple_printer_type desc printer_type =
   Ctype.begin_def();
   let ty_arg = Ctype.newvar() in
   Ctype.unify !toplevel_env
@@ -299,7 +299,7 @@ let match_simple_printer_type ppf desc printer_type =
   Ctype.generalize ty_arg;
   (ty_arg, None)
 
-let match_generic_printer_type ppf desc path args printer_type =
+let match_generic_printer_type desc path args printer_type =
   Ctype.begin_def();
   let args = List.map (fun _ -> Ctype.newvar ()) args in
   let ty_target = Ctype.newty (Tconstr (path, args, ref Mnil)) in
@@ -324,15 +324,15 @@ let match_printer_type ppf desc =
   let printer_type_old = printer_type ppf "printer_type_old" in
   Ctype.init_def(Ident.current_time());
   try
-    (match_simple_printer_type ppf desc printer_type_new, false)
+    (match_simple_printer_type desc printer_type_new, false)
   with Ctype.Unify _ ->
     try
-      (match_simple_printer_type ppf desc printer_type_old, true)
+      (match_simple_printer_type desc printer_type_old, true)
     with Ctype.Unify _ as exn ->
       match extract_target_parameters desc.val_type with
       | None -> raise exn
       | Some (path, args) ->
-          (match_generic_printer_type ppf desc path args printer_type_new,
+          (match_generic_printer_type desc path args printer_type_new,
            false)
 
 let find_printer_type ppf lid =
@@ -358,7 +358,7 @@ let dir_install_printer ppf lid =
     | None ->
        let print_function =
          if is_old_style then
-           (fun formatter repr -> Obj.obj v (Obj.obj repr))
+           (fun _formatter repr -> Obj.obj v (Obj.obj repr))
          else
            (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in
        install_printer path ty_arg print_function
@@ -367,7 +367,7 @@ let dir_install_printer ppf lid =
          | [] ->
             let print_function =
               if is_old_style then
-                (fun formatter repr -> Obj.obj v (Obj.obj repr))
+                (fun _formatter repr -> Obj.obj v (Obj.obj repr))
               else
                 (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in
             Zero print_function
@@ -379,7 +379,7 @@ let dir_install_printer ppf lid =
 
 let dir_remove_printer ppf lid =
   try
-    let (ty_arg, path, is_old_style) = find_printer_type ppf lid in
+    let (_ty_arg, path, _is_old_style) = find_printer_type ppf lid in
     begin try
       remove_printer path
     with Not_found ->
@@ -414,7 +414,7 @@ let dir_trace ppf lid =
     let (path, desc) = Env.lookup_value lid !toplevel_env in
     (* Check if this is a primitive *)
     match desc.val_kind with
-    | Val_prim p ->
+    | Val_prim _ ->
         fprintf ppf "%a is an external function and cannot be traced.@."
         Printtyp.longident lid
     | _ ->
@@ -449,7 +449,7 @@ let dir_trace ppf lid =
 
 let dir_untrace ppf lid =
   try
-    let (path, desc) = Env.lookup_value lid !toplevel_env in
+    let (path, _desc) = Env.lookup_value lid !toplevel_env in
     let rec remove = function
     | [] ->
         fprintf ppf "%a was not traced.@." Printtyp.longident lid;
@@ -530,7 +530,7 @@ let reg_show_prim name to_sig doc =
 let () =
   reg_show_prim "show_val"
     (fun env loc id lid ->
-       let path, desc = Typetexp.find_value env loc lid in
+       let _path, desc = Typetexp.find_value env loc lid in
        [ Sig_value (id, desc) ]
     )
     "Print the signature of the corresponding value."
@@ -538,7 +538,7 @@ let () =
 let () =
   reg_show_prim "show_type"
     (fun env loc id lid ->
-       let path, desc = Typetexp.find_type env loc lid in
+       let _path, desc = Typetexp.find_type env loc lid in
        [ Sig_type (id, desc, Trec_not) ]
     )
     "Print the signature of the corresponding type constructor."
@@ -569,16 +569,25 @@ let () =
 let () =
   reg_show_prim "show_module"
     (fun env loc id lid ->
-       let path, md = Typetexp.find_module env loc lid in
-       [ Sig_module (id, {md with md_type = trim_signature md.md_type},
-                     Trec_not) ]
+       let rec accum_aliases path acc =
+         let md = Env.find_module path env in
+         let acc =
+           Sig_module (id, {md with md_type = trim_signature md.md_type},
+                       Trec_not) :: acc in
+         match md.md_type with
+         | Mty_alias(_, path) -> accum_aliases path acc
+         | Mty_ident _ | Mty_signature _ | Mty_functor _ ->
+             List.rev acc
+       in
+       let path, _ = Typetexp.find_module env loc lid in
+       accum_aliases path []
     )
     "Print the signature of the corresponding module."
 
 let () =
   reg_show_prim "show_module_type"
     (fun env loc id lid ->
-       let path, desc = Typetexp.find_modtype env loc lid in
+       let _path, desc = Typetexp.find_modtype env loc lid in
        [ Sig_modtype (id, desc) ]
     )
     "Print the signature of the corresponding module type."
@@ -586,7 +595,7 @@ let () =
 let () =
   reg_show_prim "show_class"
     (fun env loc id lid ->
-       let path, desc = Typetexp.find_class env loc lid in
+       let _path, desc = Typetexp.find_class env loc lid in
        [ Sig_class (id, desc, Trec_not) ]
     )
     "Print the signature of the corresponding class."
@@ -594,7 +603,7 @@ let () =
 let () =
   reg_show_prim "show_class_type"
     (fun env loc id lid ->
-       let path, desc = Typetexp.find_class_type env loc lid in
+       let _path, desc = Typetexp.find_class_type env loc lid in
        [ Sig_class_type (id, desc, Trec_not) ]
     )
     "Print the signature of the corresponding class type."
@@ -740,9 +749,9 @@ let print_directive ppf (name, directive, doc) =
     | Directive_bool _ -> " "
     | Directive_ident _ -> " " in
   match doc with
-  | None -> printf "#%s%s@." name param
+  | None -> fprintf ppf "#%s%s@." name param
   | Some doc ->
-      printf "@[#%s%s@\n%a@]@."
+      fprintf ppf "@[#%s%s@\n%a@]@."
         name param
         Format.pp_print_text doc
 
diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml
index 1e54ed7d..e832fde5 100644
--- a/toplevel/toploop.ml
+++ b/toplevel/toploop.ml
@@ -65,9 +65,9 @@ let rec eval_path = function
         with Not_found ->
           raise (Symtable.Error(Symtable.Undefined_global name))
       end
-  | Pdot(p, s, pos) ->
+  | Pdot(p, _s, pos) ->
       Obj.field (eval_path p) pos
-  | Papply(p1, p2) ->
+  | Papply _ ->
       fatal_error "Toploop.eval_path"
 
 let eval_path env path =
@@ -158,7 +158,7 @@ let record_backtrace () =
 
 let load_lambda ppf lam =
   if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam;
-  let slam = Simplif.simplify_lambda lam in
+  let slam = Simplif.simplify_lambda "//toplevel//" lam in
   if !Clflags.dump_lambda then fprintf ppf "%a@." Printlambda.lambda slam;
   let (init_code, fun_code) = Bytegen.compile_phrase slam in
   if !Clflags.dump_instr then
@@ -334,7 +334,7 @@ let execute_phrase print_outcome ppf phr =
                        dir_name;
                false
              end
-          | Directive_int f, Pdir_int (n, Some _) ->
+          | Directive_int _, Pdir_int (_, Some _) ->
               fprintf ppf "Wrong integer literal for directive `%s'.@."
                 dir_name;
               false
@@ -352,19 +352,6 @@ let execute_phrase print_outcome ppf phr =
     Warnings.reset_fatal ();
     raise exn
 
-(* Temporary assignment to a reference *)
-
-let protect r newval body =
-  let oldval = !r in
-  try
-    r := newval;
-    let res = body() in
-    r := oldval;
-    res
-  with x ->
-    r := oldval;
-    raise x
-
 (* Read and execute commands from a file, or from stdin if [name] is "". *)
 
 let use_print_results = ref true
@@ -376,6 +363,9 @@ let preprocess_phrase ppf phr =
         let str =
           Pparse.apply_rewriters_str ~restore:true ~tool_name:"ocaml" str
         in
+        let str =
+          Pparse.ImplementationHooks.apply_hooks
+            { Misc.sourcefile = "//toplevel//" } str in
         Ptop_def str
     | phr -> phr
   in
@@ -398,9 +388,9 @@ let use_file ppf wrap_mod name =
     Warnings.reset_fatal ();
     Location.init lb filename;
     (* Skip initial #! line if any *)
-    Lexer.skip_sharp_bang lb;
+    Lexer.skip_hash_bang lb;
     let success =
-      protect Location.input_name filename (fun () ->
+      protect_refs [ R (Location.input_name, filename) ] (fun () ->
         try
           List.iter
             (fun ph ->
@@ -423,7 +413,7 @@ let mod_use_file ppf name = use_file ppf true name
 let use_file ppf name = use_file ppf false name
 
 let use_silently ppf name =
-  protect use_print_results false (fun () -> use_file ppf name)
+  protect_refs [ R (use_print_results, false) ] (fun () -> use_file ppf name)
 
 (* Reading function for interactive use *)
 
@@ -508,7 +498,9 @@ let set_paths () =
      but keep the directories that user code linked in with ocamlmktop
      may have added to load_path. *)
   load_path := !load_path @ [Filename.concat Config.standard_library "camlp4"];
-  load_path := "" :: (List.rev !Clflags.include_dirs @ !load_path);
+  load_path := "" :: List.rev (!Compenv.last_include_dirs @
+                               !Clflags.include_dirs @
+                               !Compenv.first_include_dirs) @ !load_path;
   Dll.add_path !load_path
 
 let initialize_toplevel_env () =
@@ -520,7 +512,8 @@ exception PPerror
 
 let loop ppf =
   Location.formatter_for_warnings := ppf;
-  fprintf ppf "        OCaml version %s@.@." Config.version;
+  if not !Clflags.noversion then
+    fprintf ppf "        OCaml version %s@.@." Config.version;
   begin
     try initialize_toplevel_env ()
     with Env.Error _ | Typetexp.Error _ as exn ->
@@ -552,12 +545,15 @@ let loop ppf =
 
 (* Execute a script.  If [name] is "", read the script from stdin. *)
 
-let run_script ppf name args =
+let override_sys_argv args =
   let len = Array.length args in
-  if Array.length Sys.argv < len then invalid_arg "Toploop.run_script";
+  if Array.length Sys.argv < len then invalid_arg "Toploop.override_sys_argv";
   Array.blit args 0 Sys.argv 0 len;
   Obj.truncate (Obj.repr Sys.argv) len;
-  Arg.current := 0;
+  Arg.current := 0
+
+let run_script ppf name args =
+  override_sys_argv args;
   Compmisc.init_path ~dir:(Filename.dirname name) true;
                    (* Note: would use [Filename.abspath] here, if we had it. *)
   begin
diff --git a/toplevel/toploop.mli b/toplevel/toploop.mli
index ba2f0c6d..7a478b3c 100644
--- a/toplevel/toploop.mli
+++ b/toplevel/toploop.mli
@@ -145,3 +145,13 @@ val toplevel_startup_hook : (unit -> unit) ref
 (* Used by Trace module *)
 
 val may_trace : bool ref
+
+(* Misc *)
+
+val override_sys_argv : string array -> unit
+(* [override_sys_argv args] replaces the contents of [Sys.argv] by [args]
+   and reset [Arg.current] to [0].
+
+   This is called by [run_script] so that [Sys.argv] represents
+   "script.ml args..." instead of the full command line:
+   "ocamlrun unix.cma ... script.ml args...". *)
diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml
index 581abd43..16f0c76b 100644
--- a/toplevel/topmain.ml
+++ b/toplevel/topmain.ml
@@ -25,7 +25,11 @@ let prepare ppf =
   Toploop.set_paths ();
   try
     let res =
-      List.for_all (Topdirs.load_file ppf) (List.rev !preload_objects) in
+      let objects =
+        List.rev (!preload_objects @ !first_objfiles)
+      in
+      List.for_all (Topdirs.load_file ppf) objects
+    in
     !Toploop.toplevel_startup_hook ();
     res
   with x ->
@@ -81,6 +85,7 @@ module Options = Main_args.Make_bytetop_options (struct
   let _nopromptcont = set nopromptcont
   let _nostdlib = set no_std_include
   let _open s = open_modules := s :: !open_modules
+  let _plugin p = Compplugin.load p
   let _ppx s = first_ppx := s :: !first_ppx
   let _principal = set principal
   let _no_principal = clear principal
@@ -93,10 +98,13 @@ module Options = Main_args.Make_bytetop_options (struct
   let _no_strict_sequence = clear strict_sequence
   let _strict_formats = set strict_formats
   let _no_strict_formats = clear strict_formats
+  let _unboxed_types = set unboxed_types
+  let _no_unboxed_types = clear unboxed_types
   let _unsafe = set fast
   let _unsafe_string = set unsafe_string
   let _version () = print_version ()
   let _vnum () = print_version_num ()
+  let _no_version = set noversion
   let _w s = Warnings.parse_options false s
   let _warn_error s = Warnings.parse_options true s
   let _warn_help = Warnings.help_warnings
diff --git a/toplevel/trace.ml b/toplevel/trace.ml
index fbc03427..cc732a61 100644
--- a/toplevel/trace.ml
+++ b/toplevel/trace.ml
@@ -67,7 +67,7 @@ let rec instrument_result env name ppf clos_typ =
         match name with
         | Lident s -> Lident(s ^ "*")
         | Ldot(lid, s) -> Ldot(lid, s ^ "*")
-        | Lapply(l1, l2) -> fatal_error "Trace.instrument_result" in
+        | Lapply _ -> fatal_error "Trace.instrument_result" in
       let trace_res = instrument_result env starred_name ppf t2 in
       (fun clos_val ->
         Obj.repr (fun arg ->
diff --git a/typing/btype.ml b/typing/btype.ml
index 69c93647..686bfc44 100644
--- a/typing/btype.ml
+++ b/typing/btype.ml
@@ -352,7 +352,7 @@ let type_iterators =
     it.it_path ctd.clty_path
   and it_module_type it = function
       Mty_ident p
-    | Mty_alias p -> it.it_path p
+    | Mty_alias(_, p) -> it.it_path p
     | Mty_signature sg -> it.it_signature it sg
     | Mty_functor (_, mto, mt) ->
         may (it.it_module_type it) mto;
@@ -383,7 +383,7 @@ let type_iterators =
     | Tvariant row ->
         may (fun (p,_) -> it.it_path p) (row_repr row).row_name
     | _ -> ()
-  and it_path p = ()
+  and it_path _p = ()
   in
   { it_path; it_type_expr = it_do_type_expr; it_do_type_expr;
     it_type_kind; it_class_type; it_module_type;
@@ -436,12 +436,12 @@ let rec copy_type_desc ?(keep_names=false) f = function
   | Tobject(ty, {contents = Some (p, tl)})
                         -> Tobject (f ty, ref (Some(p, List.map f tl)))
   | Tobject (ty, _)     -> Tobject (f ty, ref None)
-  | Tvariant row        -> assert false (* too ambiguous *)
+  | Tvariant _          -> assert false (* too ambiguous *)
   | Tfield (p, k, ty1, ty2) -> (* the kind is kept shared *)
       Tfield (p, field_kind_repr k, f ty1, f ty2)
   | Tnil                -> Tnil
   | Tlink ty            -> copy_type_desc f ty.desc
-  | Tsubst ty           -> assert false
+  | Tsubst _            -> assert false
   | Tunivar _ as ty     -> ty (* always keep the name *)
   | Tpoly (ty, tyl)     ->
       let tyl = List.map (fun x -> norm_univar (f x)) tyl in
@@ -510,7 +510,7 @@ let rec unmark_type ty =
   end
 
 let unmark_iterators =
-  let it_type_expr it ty = unmark_type ty in
+  let it_type_expr _it ty = unmark_type ty in
   {type_iterators with it_type_expr}
 
 let unmark_type_decl decl =
@@ -523,7 +523,7 @@ let unmark_extension_constructor ext =
 
 let unmark_class_signature sign =
   unmark_type sign.csig_self;
-  Vars.iter (fun l (m, v, t) -> unmark_type t) sign.csig_vars
+  Vars.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_vars
 
 let unmark_class_type cty =
   unmark_iterators.it_class_type unmark_iterators cty
@@ -542,7 +542,7 @@ let lte_public p1 p2 =  (* Private <= Public *)
 
 let rec find_expans priv p1 = function
     Mnil -> None
-  | Mcons (priv', p2, ty0, ty, _)
+  | Mcons (priv', p2, _ty0, ty, _)
     when lte_public priv priv' && Path.same p1 p2 -> Some ty
   | Mcons (_, _, _, _, rem)   -> find_expans priv p1 rem
   | Mlink {contents = rem} -> find_expans priv p1 rem
@@ -718,7 +718,7 @@ let rec rev_compress_log log r =
   | Change (_, next) ->
       rev_compress_log log next
 
-let undo_compress (changes, old) =
+let undo_compress (changes, _old) =
   match !changes with
     Unchanged
   | Invalid -> ()
diff --git a/typing/cmi_format.ml b/typing/cmi_format.ml
index c37bb20e..67795219 100644
--- a/typing/cmi_format.ml
+++ b/typing/cmi_format.ml
@@ -17,6 +17,7 @@ type pers_flags =
   | Rectypes
   | Deprecated of string
   | Opaque
+  | Unsafe_string
 
 type error =
     Not_an_interface of string
diff --git a/typing/cmi_format.mli b/typing/cmi_format.mli
index 252f2f64..d36612b1 100644
--- a/typing/cmi_format.mli
+++ b/typing/cmi_format.mli
@@ -17,6 +17,7 @@ type pers_flags =
   | Rectypes
   | Deprecated of string
   | Opaque
+  | Unsafe_string
 
 type cmi_infos = {
     cmi_name : string;
diff --git a/typing/ctype.ml b/typing/ctype.ml
index 75211e14..96dbbb2b 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -284,9 +284,9 @@ let associate_fields fields1 fields2 =
         (List.rev p, List.rev s, (List.rev s') @ l')
     | ((n, k, t)::r, (n', k', t')::r') when n = n' ->
         associate ((n, k, t, k', t')::p) s s' (r, r')
-    | ((n, k, t)::r, ((n', k', t')::_ as l')) when n < n' ->
+    | ((n, k, t)::r, ((n', _k', _t')::_ as l')) when n < n' ->
         associate p ((n, k, t)::s) s' (r, l')
-    | (((n, k, t)::r as l), (n', k', t')::r') (* when n > n' *) ->
+    | (((_n, _k, _t)::_ as l), (n', k', t')::r') (* when n > n' *) ->
         associate p s ((n', k', t')::s') (l, r')
   in
   associate [] [] [] (fields1, fields2)
@@ -345,7 +345,7 @@ let row_variable ty =
 
 let set_object_name id rv params ty =
   match (repr ty).desc with
-    Tobject (fi, nm) ->
+    Tobject (_fi, nm) ->
       set_name nm (Some (Path.Pident id, rv::params))
   | _ ->
       assert false
@@ -382,7 +382,7 @@ let rec signature_of_class_type =
   function
     Cty_constr (_, _, cty) -> signature_of_class_type cty
   | Cty_signature sign     -> sign
-  | Cty_arrow (_, ty, cty)   -> signature_of_class_type cty
+  | Cty_arrow (_, _, cty)   -> signature_of_class_type cty
 
 let self_type cty =
   repr (signature_of_class_type cty).csig_self
@@ -418,7 +418,7 @@ let merge_row_fields fi1 fi2 =
 
 let rec filter_row_fields erase = function
     [] -> []
-  | (l,f as p)::fi ->
+  | (_l,f as p)::fi ->
       let fi = filter_row_fields erase fi in
       match row_field_repr f with
         Rabsent -> fi
@@ -511,7 +511,7 @@ let closed_type_decl decl =
                 | Cstr_record l -> List.iter (fun l -> closed_type l.ld_type) l
           )
           v
-    | Type_record(r, rep) ->
+    | Type_record(r, _rep) ->
         List.iter (fun l -> closed_type l.ld_type) r
     | Type_open -> ()
     end;
@@ -659,7 +659,7 @@ let rec generalize_spine ty =
   | _ -> ()
 
 let forward_try_expand_once = (* Forward declaration *)
-  ref (fun env ty -> raise Cannot_expand)
+  ref (fun _env _ty -> raise Cannot_expand)
 
 (*
    Lower the levels of a type (assume [level] is not
@@ -707,7 +707,7 @@ let rec update_level env level ty =
     | None -> ()
     end;
     match ty.desc with
-      Tconstr(p, tl, abbrev) when level < get_level env p ->
+      Tconstr(p, _tl, _abbrev) when level < get_level env p ->
         (* Try first to replace an abbreviation by its expansion. *)
         begin try
           (* if is_newtype env p then raise Cannot_expand; *)
@@ -724,14 +724,14 @@ let rec update_level env level ty =
         if Path.same p p' then raise (Unify [(ty, newvar2 level)]);
         log_type ty; ty.desc <- Tpackage (p', nl, tl);
         update_level env level ty
-    | Tobject(_, ({contents=Some(p, tl)} as nm))
+    | Tobject(_, ({contents=Some(p, _tl)} as nm))
       when level < get_level env p ->
         set_name nm None;
         update_level env level ty
     | Tvariant row ->
         let row = row_repr row in
         begin match row.row_name with
-        | Some (p, tl) when level < get_level env p ->
+        | Some (p, _tl) when level < get_level env p ->
             log_type ty;
             ty.desc <- Tvariant {row with row_name = None}
         | _ -> ()
@@ -749,40 +749,36 @@ let rec update_level env level ty =
 
 (* Generalize and lower levels of contravariant branches simultaneously *)
 
-let generalize_contravariant env =
-  if !Clflags.principal then generalize_structure else update_level env
-
-let rec generalize_expansive env var_level ty =
+let rec generalize_expansive env var_level visited ty =
   let ty = repr ty in
-  if ty.level <> generic_level then begin
-    if ty.level > var_level then begin
-      set_level ty generic_level;
-      match ty.desc with
-        Tconstr (path, tyl, abbrev) ->
-          let variance =
-            try (Env.find_type path env).type_variance
-            with Not_found -> List.map (fun _ -> Variance.may_inv) tyl in
-          abbrev := Mnil;
-          List.iter2
-            (fun v t ->
-              if Variance.(mem May_weak v)
-              then generalize_contravariant env var_level t
-              else generalize_expansive env var_level t)
-            variance tyl
-      | Tpackage (_, _, tyl) ->
-          List.iter (generalize_contravariant env var_level) tyl
-      | Tarrow (_, t1, t2, _) ->
-          generalize_contravariant env var_level t1;
-          generalize_expansive env var_level t2
-      | _ ->
-          iter_type_expr (generalize_expansive env var_level) ty
-    end
+  if ty.level = generic_level || ty.level <= var_level then () else
+  if not (Hashtbl.mem visited ty.id) then begin
+    Hashtbl.add visited ty.id ();
+    match ty.desc with
+      Tconstr (path, tyl, abbrev) ->
+        let variance =
+          try (Env.find_type path env).type_variance
+          with Not_found -> List.map (fun _ -> Variance.may_inv) tyl in
+        abbrev := Mnil;
+        List.iter2
+          (fun v t ->
+            if Variance.(mem May_weak v)
+            then generalize_structure var_level t
+            else generalize_expansive env var_level visited t)
+          variance tyl
+    | Tpackage (_, _, tyl) ->
+        List.iter (generalize_structure var_level) tyl
+    | Tarrow (_, t1, t2, _) ->
+        generalize_structure var_level t1;
+        generalize_expansive env var_level visited t2
+    | _ ->
+        iter_type_expr (generalize_expansive env var_level visited) ty
   end
 
 let generalize_expansive env ty =
   simple_abbrevs := Mnil;
   try
-    generalize_expansive env !nongen_level ty
+    generalize_expansive env !nongen_level (Hashtbl.create 7) ty
   with Unify ([_, ty'] as tr) ->
     raise (Unify ((ty, ty') :: tr))
 
@@ -864,7 +860,7 @@ let compute_univars ty =
   let node_univars = TypeHash.create 17 in
   let rec add_univar univ inv =
     match inv.inv_type.desc with
-      Tpoly (ty, tl) when List.memq univ (List.map repr tl) -> ()
+      Tpoly (_ty, tl) when List.memq univ (List.map repr tl) -> ()
     | _ ->
         try
           let univs = TypeHash.find node_univars inv.inv_type in
@@ -1025,7 +1021,7 @@ let rec copy ?env ?partial ?keep_names ty =
               (* Return a new copy *)
               Tvariant (copy_row copy true row keep more')
           end
-      | Tfield (p, k, ty1, ty2) ->
+      | Tfield (_p, k, _ty1, ty2) ->
           begin match field_kind_repr k with
             Fabsent  -> Tlink (copy ty2)
           | Fpresent -> copy_type_desc copy desc
@@ -1064,7 +1060,7 @@ let instance_def sch =
   cleanup_types ();
   ty
 
-let generic_instance ?partial env sch =
+let generic_instance env sch =
   let old = !current_level in
   current_level := generic_level;
   let ty = instance env sch in
@@ -1104,6 +1100,7 @@ let new_declaration newtype manifest =
     type_loc = Location.none;
     type_attributes = [];
     type_immediate = false;
+    type_unboxed = unboxed_false_default_false;
   }
 
 let instance_constructor ?in_pattern cstr =
@@ -1117,10 +1114,10 @@ let instance_constructor ?in_pattern cstr =
             {desc = Tvar (Some name)} -> "$" ^ cstr.cstr_name ^ "_'" ^ name
           | _ -> "$" ^ cstr.cstr_name
         in
-        let (id, new_env) =
-          Env.enter_type (get_new_abstract_name name) decl !env in
+        let path = Path.Pident (Ident.create (get_new_abstract_name name)) in
+        let new_env = Env.add_local_type path decl !env in
         env := new_env;
-        let to_unify = newty (Tconstr (Path.Pident id,[],ref Mnil)) in
+        let to_unify = newty (Tconstr (path,[],ref Mnil)) in
         let tv = copy existential in
         assert (is_Tvar tv);
         link_type tv to_unify
@@ -1281,7 +1278,7 @@ let instance_label fixed lbl =
     match repr lbl.lbl_arg with
       {desc = Tpoly (ty, tl)} ->
         instance_poly fixed tl ty
-    | ty ->
+    | _ ->
         [], copy lbl.lbl_arg
   in
   cleanup_types ();
@@ -1290,7 +1287,7 @@ let instance_label fixed lbl =
 (**** Instantiation with parameter substitution ****)
 
 let unify' = (* Forward declaration *)
-  ref (fun env ty1 ty2 -> raise (Unify []))
+  ref (fun _env _ty1 _ty2 -> raise (Unify []))
 
 let subst env level priv abbrev ty params args body =
   if List.length params <> List.length args then raise (Unify []);
@@ -1387,32 +1384,35 @@ let expand_abbrev_gen kind find_type_expansion env ty =
               ()
             end;
           let ty' = repr ty' in
-          assert (ty != ty');
+          (* assert (ty != ty'); *) (* PR#7324 *)
           ty'
       | None ->
-          let (params, body, lv) =
-            try find_type_expansion path env with Not_found ->
-              raise Cannot_expand
-          in
-          (* prerr_endline
-            ("add a "^string_of_kind kind^" expansion for "^Path.name path);*)
-          let ty' = subst env level kind abbrev (Some ty) params args body in
-          (* Hack to name the variant type *)
-          begin match repr ty' with
-            {desc=Tvariant row} as ty when static_row row ->
-              ty.desc <- Tvariant { row with row_name = Some (path, args) }
-          | _ -> ()
-          end;
-          (* For gadts, remember type as non exportable *)
-          (* The ambiguous level registered for ty' should be the highest *)
-          if !trace_gadt_instances then begin
-            match max lv (Env.gadt_instance_level env ty) with
-              None -> ()
-            | Some lv ->
-                if level < lv then raise (Unify [(ty, newvar2 level)]);
-                Env.add_gadt_instances env lv [ty; ty']
-          end;
-          ty'
+          match find_type_expansion path env with
+          | exception Not_found ->
+            (* another way to expand is to normalize the path itself *)
+            let path' = Env.normalize_path None env path in
+            if Path.same path path' then raise Cannot_expand
+            else newty2 level (Tconstr (path', args, abbrev))
+          | (params, body, lv) ->
+            (* prerr_endline
+              ("add a "^string_of_kind kind^" expansion for "^Path.name path);*)
+            let ty' = subst env level kind abbrev (Some ty) params args body in
+            (* Hack to name the variant type *)
+            begin match repr ty' with
+              {desc=Tvariant row} as ty when static_row row ->
+                ty.desc <- Tvariant { row with row_name = Some (path, args) }
+            | _ -> ()
+            end;
+            (* For gadts, remember type as non exportable *)
+            (* The ambiguous level registered for ty' should be the highest *)
+            if !trace_gadt_instances then begin
+              match max lv (Env.gadt_instance_level env ty) with
+                None -> ()
+              | Some lv ->
+                  if level < lv then raise (Unify [(ty, newvar2 level)]);
+                  Env.add_gadt_instances env lv [ty; ty']
+            end;
+            ty'
       end
   | _ ->
       assert false
@@ -1439,7 +1439,7 @@ let safe_abbrev env ty =
 let try_expand_once env ty =
   let ty = repr ty in
   match ty.desc with
-    Tconstr (p, _, _) -> repr (expand_abbrev env ty)
+    Tconstr _ -> repr (expand_abbrev env ty)
   | _ -> raise Cannot_expand
 
 (* This one only raises Cannot_expand *)
@@ -1524,7 +1524,7 @@ let expand_head_opt env ty =
    respect the type constraints *)
 let enforce_constraints env ty =
   match ty with
-    {desc = Tconstr (path, args, abbrev); level = level} ->
+    {desc = Tconstr (path, args, _abbrev); level = level} ->
       begin try
         let decl = Env.find_type path env in
         ignore
@@ -1588,7 +1588,7 @@ let rec occur_rec env allow_recursive visited ty0 = function
   | ty ->
   if ty == ty0  then raise Occur;
   match ty.desc with
-    Tconstr(p, tl, abbrev) ->
+    Tconstr(p, _tl, _abbrev) ->
       if allow_recursive && is_contractive env p then () else
       begin try
         if TypeSet.mem ty visited then raise Occur;
@@ -1635,27 +1635,42 @@ let occur_in env ty0 t =
 (* PR#6405: not needed since we allow recursion and work on normalized types *)
 (* PR#6992: we actually need it for contractiveness *)
 (* This is a simplified version of occur, only for the rectypes case *)
-let rec local_non_recursive_abbrev visited env p ty =
+
+let rec local_non_recursive_abbrev strict visited env p ty =
+  (*Format.eprintf "@[Check %s =@ %a@]@." (Path.name p) !Btype.print_raw ty;*)
   let ty = repr ty in
   if not (List.memq ty visited) then begin
     match ty.desc with
-      Tconstr(p', args, abbrev) ->
+      Tconstr(p', args, _abbrev) ->
         if Path.same p p' then raise Occur;
-        if is_contractive env p' then () else
+        if not strict && is_contractive env p' then () else
         let visited = ty :: visited in
         begin try
-          List.iter (local_non_recursive_abbrev visited env p) args
-        with Occur -> try
-          local_non_recursive_abbrev visited env p
+          (* try expanding, since [p] could be hidden *)
+          local_non_recursive_abbrev strict visited env p
             (try_expand_head try_expand_once env ty)
         with Cannot_expand ->
-          raise Occur
+          let params =
+            try (Env.find_type p' env).type_params
+            with Not_found -> args
+          in
+          List.iter2
+            (fun tv ty ->
+              let strict = strict || not (is_Tvar (repr tv)) in
+              local_non_recursive_abbrev strict visited env p ty)
+            params args
         end
-    | _ -> ()
+    | _ ->
+        if strict then (* PR#7374 *)
+          let visited = ty :: visited in
+          iter_type_expr (local_non_recursive_abbrev true visited env p) ty
   end
 
 let local_non_recursive_abbrev env p ty =
-  try local_non_recursive_abbrev [] env p ty; true
+  try (* PR#7397: need to check trace_gadt_instances *)
+    wrap_trace_gadt_instances env
+      (local_non_recursive_abbrev false [] env p) ty;
+    true
   with Occur -> false
 
 
@@ -1826,9 +1841,6 @@ let mkvariant fields closed =
        {row_fields = fields; row_closed = closed; row_more = newvar();
         row_bound = (); row_fixed = false; row_name = None })
 
-(* force unification in Reither when one side has as non-conjunctive type *)
-let rigid_variants = ref false
-
 (**** Unification ****)
 
 (* Return whether [t0] occurs in [ty]. Objects are also traversed. *)
@@ -1885,9 +1897,9 @@ let reify env t =
   let create_fresh_constr lev name =
     let decl = new_declaration (Some (newtype_level, newtype_level)) None in
     let name = match name with Some s -> "$'"^s | _ -> "$" in
-    let name = get_new_abstract_name name in
-    let (id, new_env) = Env.enter_type name decl !env in
-    let t = newty2 lev (Tconstr (Path.Pident id,[],ref Mnil))  in
+    let path = Path.Pident (Ident.create (get_new_abstract_name name)) in
+    let new_env = Env.add_local_type path decl !env in
+    let t = newty2 lev (Tconstr (path,[],ref Mnil))  in
     env := new_env;
     t
   in
@@ -1938,6 +1950,17 @@ let non_aliasable p decl =
   (* in_pervasives p ||  (subsumed by in_current_module) *)
   in_current_module p && decl.type_newtype_level = None
 
+let is_instantiable env p =
+  try
+    let decl = Env.find_type p env in
+    decl.type_kind = Type_abstract &&
+    decl.type_private = Public &&
+    decl.type_arity = 0 &&
+    decl.type_manifest = None &&
+    not (non_aliasable p decl)
+  with Not_found -> false
+
+
 (* PR#7113: -safe-string should be a global property *)
 let compatible_paths p1 p2 =
   let open Predef in
@@ -2035,11 +2058,13 @@ and mcomp_fields type_pairs env ty1 ty2 =
   let (fields2, rest2) = flatten_fields ty2 in
   let (fields1, rest1) = flatten_fields ty1 in
   let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  let has_present =
+    List.exists (fun (_, k, _) -> field_kind_repr k = Fpresent) in
   mcomp type_pairs env rest1 rest2;
-  if miss1 <> []  && (object_row ty1).desc = Tnil
-  || miss2 <> []  && (object_row ty2).desc = Tnil then raise (Unify []);
+  if has_present miss1  && (object_row ty2).desc = Tnil
+  || has_present miss2  && (object_row ty1).desc = Tnil then raise (Unify []);
   List.iter
-    (function (n, k1, t1, k2, t2) ->
+    (function (_n, k1, t1, k2, t2) ->
        mcomp_kind k1 k2;
        mcomp type_pairs env t1 t2)
     pairs
@@ -2048,9 +2073,9 @@ and mcomp_kind k1 k2 =
   let k1 = field_kind_repr k1 in
   let k2 = field_kind_repr k2 in
   match k1, k2 with
-    (Fvar _, Fvar _)
-  | (Fpresent, Fpresent) -> ()
-  | _                    -> raise (Unify [])
+    (Fpresent, Fabsent)
+  | (Fabsent, Fpresent) -> raise (Unify [])
+  | _                   -> ()
 
 and mcomp_row type_pairs env row1 row2 =
   let row1 = row_repr row1 and row2 = row_repr row2 in
@@ -2167,17 +2192,18 @@ let find_lowest_level ty =
 let find_newtype_level env path =
   try match (Env.find_type path env).type_newtype_level with
     Some x -> x
-  | None -> assert false
-  with Not_found -> assert false
+  | None -> raise Not_found
+  with Not_found -> let lev = Path.binding_time path in (lev, lev)
 
 let add_gadt_equation env source destination =
-  if local_non_recursive_abbrev !env (Path.Pident source) destination then
+  if local_non_recursive_abbrev !env source destination then begin
     let destination = duplicate_type destination in
-    let source_lev = find_newtype_level !env (Path.Pident source) in
+    let source_lev = find_newtype_level !env source in
     let decl = new_declaration (Some source_lev) (Some destination) in
     let newtype_level = get_newtype_level () in
     env := Env.add_local_constraint source decl newtype_level !env;
     cleanup_abbrev ()
+  end
 
 let unify_eq_set = TypePairs.create 11
 
@@ -2222,10 +2248,10 @@ let complete_type_list ?(allow_absent=false) env nl1 lv2 mty2 nl2 tl2 =
         nt2 :: complete (if n = n2 then nl else nl1) ntl'
     | n :: nl, _ ->
         try
-          let (_, decl) =
+          let path =
             Env.lookup_type (concat_longident (Longident.Lident "Pkg") n) env'
           in
-          match decl with
+          match Env.find_type path env' with
             {type_arity = 0; type_kind = Type_abstract;
              type_private = Public; type_manifest = Some t2} ->
                (n, nondep_instance env' lv2 id2 t2) :: complete nl ntl2
@@ -2249,7 +2275,19 @@ let unify_package env unify_list lv1 p1 n1 tl1 lv2 p2 n2 tl2 =
   && !package_subtype env p2 n2 tl2 p1 n1 tl1 then () else raise Not_found
 
 
-let unify_eq env t1 t2 =
+(* force unification in Reither when one side has as non-conjunctive type *)
+let rigid_variants = ref false
+
+(* drop not force unification in Reither, even in fixed case
+   (not sound, only use it when checking exhaustiveness) *)
+let passive_variants = ref false
+let with_passive_variants f x =
+  if !passive_variants then f x else
+  match passive_variants := true; f x with
+  | r           -> passive_variants := false; r
+  | exception e -> passive_variants := false; raise e
+
+let unify_eq t1 t2 =
   t1 == t2 ||
   match !umode with
   | Expression -> false
@@ -2274,7 +2312,7 @@ let rec unify (env:Env.t ref) t1 t2 =
   if t1 == t2 then () else
   let t1 = repr t1 in
   let t2 = repr t2 in
-  if unify_eq !env t1 t2 then () else
+  if unify_eq t1 t2 then () else
   let reset_tracing = check_trace_gadt_instances !env in
 
   try
@@ -2331,7 +2369,7 @@ and unify2 env t1 t2 =
   let lv = min t1'.level t2'.level in
   update_level !env lv t2;
   update_level !env lv t1;
-  if unify_eq !env t1' t2' then () else
+  if unify_eq t1' t2' then () else
 
   let t1 = repr t1 and t2 = repr t2 in
   if !trace_gadt_instances then begin
@@ -2351,7 +2389,7 @@ and unify2 env t1 t2 =
       (match t2.desc with Tconstr (_, [], _) -> t2' | _ -> t2)
     else (t1, t2)
   in
-  if unify_eq !env t1 t1' || not (unify_eq !env t2 t2') then
+  if unify_eq t1 t1' || not (unify_eq t2 t2') then
     unify3 env t1 t1' t2 t2'
   else
     try unify3 env t2 t2' t1 t1' with Unify trace ->
@@ -2423,24 +2461,24 @@ and unify3 env t1 t1' t2 t2' =
                       reify env t1; reify env t2
                   end)
               inj (List.combine tl1 tl2)
-      | (Tconstr ((Path.Pident p) as path,[],_),
-         Tconstr ((Path.Pident p') as path',[],_))
-        when is_newtype !env path && is_newtype !env path'
+      | (Tconstr (path,[],_),
+         Tconstr (path',[],_))
+        when is_instantiable !env path && is_instantiable !env path'
         && !generate_equations ->
           let source, destination =
             if find_newtype_level !env path > find_newtype_level !env path'
-            then  p,t2'
-            else  p',t1'
+            then  path , t2'
+            else  path', t1'
           in
           add_gadt_equation env source destination
-      | (Tconstr ((Path.Pident p) as path,[],_), _)
-        when is_newtype !env path && !generate_equations ->
+      | (Tconstr (path,[],_), _)
+        when is_instantiable !env path && !generate_equations ->
           reify env t2';
-          add_gadt_equation env p t2'
-      | (_, Tconstr ((Path.Pident p) as path,[],_))
-        when is_newtype !env path && !generate_equations ->
+          add_gadt_equation env path t2'
+      | (_, Tconstr (path,[],_))
+        when is_instantiable !env path && !generate_equations ->
           reify env t1';
-          add_gadt_equation env p t1'
+          add_gadt_equation env path t1'
       | (Tconstr (_,_,_), _) | (_, Tconstr (_,_,_)) when !umode = Pattern ->
           reify env t1';
           reify env t2';
@@ -2573,7 +2611,7 @@ and unify_kind k1 k2 =
 and unify_row env row1 row2 =
   let row1 = row_repr row1 and row2 = row_repr row2 in
   let rm1 = row_more row1 and rm2 = row_more row2 in
-  if unify_eq !env rm1 rm2 then () else
+  if unify_eq rm1 rm2 then () else
   let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
   if r1 <> [] && r2 <> [] then begin
     let ht = Hashtbl.create (List.length r1) in
@@ -2665,6 +2703,7 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 =
   | Reither(c1, tl1, m1, e1), Reither(c2, tl2, m2, e2) ->
       if e1 == e2 then () else
       let redo =
+        not !passive_variants &&
         (m1 || m2 || fixed1 || fixed2 ||
          !rigid_variants && (List.length tl1 = 1 || List.length tl2 = 1)) &&
         begin match tl1 @ tl2 with [] -> false
@@ -2688,8 +2727,9 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 =
       and (tl2',tlu2) = split_univars tl2' in
       begin match tlu1, tlu2 with
         [], [] -> ()
-      | (tu1::tlu1), (tu2::_) ->
+      | (tu1::tlu1), _ :: _ ->
           (* Attempt to merge all the types containing univars *)
+          if not !passive_variants then
           List.iter (unify env tu1) (tlu1@tlu2)
       | (tu::_, []) | ([], tu::_) -> occur_univar !env tu
       end;
@@ -2747,8 +2787,10 @@ let unify_gadt ~newtype_level:lev (env:Env.t ref) ty1 ty2 =
 let unify_var env t1 t2 =
   let t1 = repr t1 and t2 = repr t2 in
   if t1 == t2 then () else
-  match t1.desc with
-    Tvar _ ->
+  match t1.desc, t2.desc with
+    Tvar _, Tconstr _ when deep_occur t1 t2 ->
+      unify (ref env) t1 t2
+  | Tvar _, _ ->
       let reset_tracing = check_trace_gadt_instances env in
       begin try
         occur env t1 t2;
@@ -2938,7 +2980,7 @@ let rec moregen inst_nongen type_pairs env t1 t2 =
               end
           | (Tvariant row1, Tvariant row2) ->
               moregen_row inst_nongen type_pairs env row1 row2
-          | (Tobject (fi1, nm1), Tobject (fi2, nm2)) ->
+          | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) ->
               moregen_fields inst_nongen type_pairs env fi1 fi2
           | (Tfield _, Tfield _) ->           (* Actually unused *)
               moregen_fields inst_nongen type_pairs env t1' t2'
@@ -3015,7 +3057,7 @@ and moregen_row inst_nongen type_pairs env row1 row2 =
   | _ -> raise (Unify [])
   end;
   List.iter
-    (fun (l,f1,f2) ->
+    (fun (_l,f1,f2) ->
       let f1 = row_field_repr f1 and f2 = row_field_repr f2 in
       if f1 == f2 then () else
       match f1, f2 with
@@ -3204,7 +3246,7 @@ let rec eqtype rename type_pairs subst env t1 t2 =
               end
           | (Tvariant row1, Tvariant row2) ->
               eqtype_row rename type_pairs subst env row1 row2
-          | (Tobject (fi1, nm1), Tobject (fi2, nm2)) ->
+          | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) ->
               eqtype_fields rename type_pairs subst env fi1 fi2
           | (Tfield _, Tfield _) ->       (* Actually unused *)
               eqtype_fields rename type_pairs subst env t1' t2'
@@ -3353,19 +3395,19 @@ let rec moregen_clty trace type_pairs env cty1 cty2 =
     | Cty_signature sign1, Cty_signature sign2 ->
         let ty1 = object_fields (repr sign1.csig_self) in
         let ty2 = object_fields (repr sign2.csig_self) in
-        let (fields1, rest1) = flatten_fields ty1
-        and (fields2, rest2) = flatten_fields ty2 in
-        let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+        let (fields1, _rest1) = flatten_fields ty1
+        and (fields2, _rest2) = flatten_fields ty2 in
+        let (pairs, _miss1, _miss2) = associate_fields fields1 fields2 in
         List.iter
-          (fun (lab, k1, t1, k2, t2) ->
+          (fun (lab, _k1, t1, _k2, t2) ->
             begin try moregen true type_pairs env t1 t2 with Unify trace ->
               raise (Failure [CM_Meth_type_mismatch
                                  (lab, env, expand_trace env trace)])
            end)
         pairs;
       Vars.iter
-        (fun lab (mut, v, ty) ->
-           let (mut', v', ty') = Vars.find lab sign1.csig_vars in
+        (fun lab (_mut, _v, ty) ->
+           let (_mut', _v', ty') = Vars.find lab sign1.csig_vars in
            try moregen true type_pairs env ty' ty with Unify trace ->
              raise (Failure [CM_Val_type_mismatch
                                 (lab, env, expand_trace env trace)]))
@@ -3422,16 +3464,16 @@ let match_class_types ?(trace=true) env pat_sch subj_sch =
     moregen true type_pairs env rest1 rest2;
     let error =
       List.fold_right
-        (fun (lab, k1, t1, k2, t2) err ->
+        (fun (lab, k1, _t1, k2, _t2) err ->
            try moregen_kind k1 k2; err with
              Unify _ -> CM_Public_method lab::err)
         pairs error
     in
     let error =
       Vars.fold
-        (fun lab (mut, vr, ty) err ->
+        (fun lab (mut, vr, _ty) err ->
           try
-            let (mut', vr', ty') = Vars.find lab sign1.csig_vars in
+            let (mut', vr', _ty') = Vars.find lab sign1.csig_vars in
             if mut = Mutable && mut' <> Mutable then
               CM_Non_mutable_value lab::err
             else if vr = Concrete && vr' <> Concrete then
@@ -3488,11 +3530,11 @@ let rec equal_clty trace type_pairs subst env cty1 cty2 =
     | Cty_signature sign1, Cty_signature sign2 ->
         let ty1 = object_fields (repr sign1.csig_self) in
         let ty2 = object_fields (repr sign2.csig_self) in
-        let (fields1, rest1) = flatten_fields ty1
-        and (fields2, rest2) = flatten_fields ty2 in
-        let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+        let (fields1, _rest1) = flatten_fields ty1
+        and (fields2, _rest2) = flatten_fields ty2 in
+        let (pairs, _miss1, _miss2) = associate_fields fields1 fields2 in
         List.iter
-          (fun (lab, k1, t1, k2, t2) ->
+          (fun (lab, _k1, t1, _k2, t2) ->
              begin try eqtype true type_pairs subst env t1 t2 with
                Unify trace ->
                  raise (Failure [CM_Meth_type_mismatch
@@ -3531,7 +3573,7 @@ let match_class_declarations env patt_params patt_type subj_params subj_type =
         let err =
           let k = field_kind_repr k in
           begin match k with
-            Fvar r -> err
+            Fvar _ -> err
           | _      -> CM_Hide_public lab::err
           end
         in
@@ -3547,7 +3589,7 @@ let match_class_declarations env patt_params patt_type subj_params subj_type =
   eqtype true type_pairs subst env rest1 rest2;
   let error =
     List.fold_right
-      (fun (lab, k1, t1, k2, t2) err ->
+      (fun (lab, k1, _t1, k2, _t2) err ->
         let k1 = field_kind_repr k1 in
         let k2 = field_kind_repr k2 in
         match k1, k2 with
@@ -3560,9 +3602,9 @@ let match_class_declarations env patt_params patt_type subj_params subj_type =
   in
   let error =
     Vars.fold
-      (fun lab (mut, vr, ty) err ->
+      (fun lab (mut, vr, _ty) err ->
          try
-           let (mut', vr', ty') = Vars.find lab sign1.csig_vars in
+           let (mut', vr', _ty') = Vars.find lab sign1.csig_vars in
            if mut = Mutable && mut' <> Mutable then
              CM_Non_mutable_value lab::err
            else if vr = Concrete && vr' <> Concrete then
@@ -3646,16 +3688,18 @@ let rec filter_visited = function
 let memq_warn t visited =
   if List.memq t visited then (warn := true; true) else false
 
-let rec lid_of_path ?(sharp="") = function
+let rec lid_of_path ?(hash="") = function
     Path.Pident id ->
-      Longident.Lident (sharp ^ Ident.name id)
+      Longident.Lident (hash ^ Ident.name id)
   | Path.Pdot (p1, s, _) ->
-      Longident.Ldot (lid_of_path p1, sharp ^ s)
+      Longident.Ldot (lid_of_path p1, hash ^ s)
   | Path.Papply (p1, p2) ->
-      Longident.Lapply (lid_of_path ~sharp p1, lid_of_path p2)
+      Longident.Lapply (lid_of_path ~hash p1, lid_of_path p2)
 
 let find_cltype_for_path env p =
-  let path, cl_abbr = Env.lookup_type (lid_of_path ~sharp:"#" p) env in
+  let cl_path = Env.lookup_type (lid_of_path ~hash:"#" p) env in
+  let cl_abbr = Env.find_type cl_path env in
+
   match cl_abbr.type_manifest with
     Some ty ->
       begin match (repr ty).desc with
@@ -3737,7 +3781,7 @@ let rec build_subtype env visited loops posi level t =
         if c > Unchanged then (t'',c)
         else (t, Unchanged)
       end
-  | Tconstr(p, tl, abbrev) ->
+  | Tconstr(p, tl, _abbrev) ->
       (* Must check recursion on constructors, since we do not always
          expand them *)
       if memq_warn t visited then (t, Unchanged) else
@@ -3876,10 +3920,10 @@ let rec subtype_rec env trace t1 t2 cstrs =
         subtype_list env trace tl1 tl2 cstrs
     | (Tconstr(p1, [], _), Tconstr(p2, [], _)) when Path.same p1 p2 ->
         cstrs
-    | (Tconstr(p1, tl1, abbrev1), _)
+    | (Tconstr(p1, _tl1, _abbrev1), _)
       when generic_abbrev env p1 && safe_abbrev env t1 ->
         subtype_rec env trace (expand_abbrev env t1) t2 cstrs
-    | (_, Tconstr(p2, tl2, abbrev2))
+    | (_, Tconstr(p2, _tl2, _abbrev2))
       when generic_abbrev env p2 && safe_abbrev env t2 ->
         subtype_rec env trace t1 (expand_abbrev env t2) cstrs
     | (Tconstr(p1, tl1, _), Tconstr(p2, tl2, _)) when Path.same p1 p2 ->
@@ -3983,7 +4027,7 @@ and subtype_fields env trace ty1 ty2 cstrs =
      !univar_pairs) :: cstrs
   in
   List.fold_left
-    (fun cstrs (_, k1, t1, k2, t2) ->
+    (fun cstrs (_, _k1, t1, _k2, t2) ->
       (* Theses fields are always present *)
       subtype_rec env ((t1, t2)::trace) t1 t2 cstrs)
     cstrs pairs
@@ -4082,7 +4126,7 @@ let unalias ty =
 (* Return the arity (as for curried functions) of the given type. *)
 let rec arity ty =
   match (repr ty).desc with
-    Tarrow(_, t1, t2, _) -> 1 + arity t2
+    Tarrow(_, _t1, t2, _) -> 1 + arity t2
   | _ -> 0
 
 (* Check whether an abbreviation expands to itself. *)
@@ -4090,7 +4134,7 @@ let cyclic_abbrev env id ty =
   let rec check_cycle seen ty =
     let ty = repr ty in
     match ty.desc with
-      Tconstr (p, tl, abbrev) ->
+      Tconstr (p, _tl, _abbrev) ->
         p = Path.Pident id || List.memq ty seen ||
         begin try
           check_cycle (ty :: seen) (expand_abbrev_opt env ty)
@@ -4107,12 +4151,21 @@ exception Non_closed0
 let visited = ref TypeSet.empty
 
 let rec closed_schema_rec env ty =
-  let ty = expand_head env ty in
+  let ty = repr ty in
   if TypeSet.mem ty !visited then () else begin
     visited := TypeSet.add ty !visited;
     match ty.desc with
       Tvar _ when ty.level <> generic_level ->
         raise Non_closed0
+    | Tconstr _ ->
+        let old = !visited in
+        begin try iter_type_expr (closed_schema_rec env) ty
+        with Non_closed0 -> try
+          visited := old;
+          closed_schema_rec env (try_expand_head try_expand_safe env ty)
+        with Cannot_expand ->
+          raise Non_closed0
+        end
     | Tfield(_, kind, t1, t2) ->
         if field_kind_repr kind = Fpresent then
           closed_schema_rec env t1;
@@ -4225,7 +4278,7 @@ let rec nondep_type_rec env id ty =
     TypeHash.add nondep_hash ty ty';
     ty'.desc <-
       begin match ty.desc with
-      | Tconstr(p, tl, abbrev) ->
+      | Tconstr(p, tl, _abbrev) ->
           if Path.isfree id p then
             begin try
               Tlink (nondep_type_rec env id
@@ -4270,7 +4323,7 @@ let rec nondep_type_rec env id ty =
             let row =
               copy_row (nondep_type_rec env id) true row true more' in
             match row.row_name with
-              Some (p, tl) when Path.isfree id p ->
+              Some (p, _tl) when Path.isfree id p ->
                 Tvariant {row with row_name = None}
             | _ -> Tvariant row
           end
@@ -4330,6 +4383,7 @@ let nondep_type_decl env mid id is_covariant decl =
       type_loc = decl.type_loc;
       type_attributes = decl.type_attributes;
       type_immediate = decl.type_immediate;
+      type_unboxed = decl.type_unboxed;
     }
   with Not_found ->
     clear_hash ();
@@ -4436,7 +4490,7 @@ let rec collapse_conj env visited ty =
     Tvariant row ->
       let row = row_repr row in
       List.iter
-        (fun (l,fi) ->
+        (fun (_l,fi) ->
           match row_field_repr fi with
             Reither (c, t1::(_::_ as tl), m, e) ->
               List.iter (unify env t1) tl;
@@ -4463,7 +4517,7 @@ let () =
 
 let maybe_pointer_type env typ =
    match (repr typ).desc with
-  | Tconstr(p, args, abbrev) ->
+  | Tconstr(p, _args, _abbrev) ->
     begin try
       let type_decl = Env.find_type p env in
       not type_decl.type_immediate
diff --git a/typing/ctype.mli b/typing/ctype.mli
index 6da7fa86..f7a22e21 100644
--- a/typing/ctype.mli
+++ b/typing/ctype.mli
@@ -81,7 +81,7 @@ val set_object_name:
 val remove_object_name: type_expr -> unit
 val hide_private_methods: type_expr -> unit
 val find_cltype_for_path: Env.t -> Path.t -> type_declaration * type_expr
-val lid_of_path: ?sharp:string -> Path.t -> Longident.t
+val lid_of_path: ?hash:string -> Path.t -> Longident.t
 
 val sort_row_fields: (label * row_field) list -> (label * row_field) list
 val merge_row_fields:
@@ -116,7 +116,7 @@ val instance: ?partial:bool -> Env.t -> type_expr -> type_expr
            partial=true  -> newty2 ty.level Tvar for non generic subterms *)
 val instance_def: type_expr -> type_expr
         (* use defaults *)
-val generic_instance: ?partial:bool -> Env.t -> type_expr -> type_expr
+val generic_instance: Env.t -> type_expr -> type_expr
         (* Same as instance, but new nodes at generic_level *)
 val instance_list: Env.t -> type_expr list -> type_expr list
         (* Take an instance of a list of type schemes *)
@@ -170,6 +170,8 @@ val unify_gadt: newtype_level:int -> Env.t ref -> type_expr -> type_expr -> unit
 val unify_var: Env.t -> type_expr -> type_expr -> unit
         (* Same as [unify], but allow free univars when first type
            is a variable. *)
+val with_passive_variants: ('a -> 'b) -> ('a -> 'b)
+        (* Call [f] in passive_variants mode, for exhaustiveness check. *)
 val filter_arrow: Env.t -> type_expr -> arg_label -> type_expr * type_expr
         (* A special case of unification (with l:'a -> 'b). *)
 val filter_method: Env.t -> string -> private_flag -> type_expr -> type_expr
diff --git a/typing/datarepr.ml b/typing/datarepr.ml
index 1645dd9e..5c46ae15 100644
--- a/typing/datarepr.ml
+++ b/typing/datarepr.ml
@@ -49,7 +49,7 @@ let free_vars ?(param=false) ty =
 
 let newgenconstr path tyl = newgenty (Tconstr (path, tyl, ref Mnil))
 
-let constructor_args cd_args cd_res path rep =
+let constructor_existentials cd_args cd_res =
   let tyl =
     match cd_args with
     | Cstr_tuple l -> l
@@ -63,23 +63,33 @@ let constructor_args cd_args cd_res path rep =
         let res_vars = free_vars type_ret in
         TypeSet.elements (TypeSet.diff arg_vars_set res_vars)
   in
+  (tyl, existentials)
+
+let constructor_args priv cd_args cd_res path rep =
+  let tyl, existentials = constructor_existentials cd_args cd_res in
   match cd_args with
   | Cstr_tuple l -> existentials, l, None
   | Cstr_record lbls ->
       let arg_vars_set = free_vars ~param:true (newgenty (Ttuple tyl)) in
       let type_params = TypeSet.elements arg_vars_set in
+      let type_unboxed =
+        match rep with
+        | Record_unboxed _ -> unboxed_true_default_false
+        | _ -> unboxed_false_default_false
+      in
       let tdecl =
         {
           type_params;
           type_arity = List.length type_params;
           type_kind = Type_record (lbls, rep);
-          type_private = Public;
+          type_private = priv;
           type_manifest = None;
           type_variance = List.map (fun _ -> Variance.full) type_params;
           type_newtype_level = None;
           type_loc = Location.none;
           type_attributes = [];
           type_immediate = false;
+          type_unboxed;
         }
       in
       existentials,
@@ -104,16 +114,22 @@ let constructor_descrs ty_path decl cstrs =
         in
         let (tag, descr_rem) =
           match cd_args with
-            Cstr_tuple [] -> (Cstr_constant idx_const,
+          | _ when decl.type_unboxed.unboxed ->
+            assert (rem = []);
+            (Cstr_unboxed, [])
+          | Cstr_tuple [] -> (Cstr_constant idx_const,
                    describe_constructors (idx_const+1) idx_nonconst rem)
           | _  -> (Cstr_block idx_nonconst,
                    describe_constructors idx_const (idx_nonconst+1) rem) in
-
         let cstr_name = Ident.name cd_id in
         let existentials, cstr_args, cstr_inlined =
-          constructor_args cd_args cd_res
-            (Path.Pdot (ty_path, cstr_name, Path.nopos))
-            (Record_inlined idx_nonconst)
+          let representation =
+            if decl.type_unboxed.unboxed
+            then Record_unboxed true
+            else Record_inlined idx_nonconst
+          in
+          constructor_args decl.type_private cd_args cd_res
+            (Path.Pdot (ty_path, cstr_name, Path.nopos)) representation
         in
         let cstr =
           { cstr_name;
@@ -141,7 +157,7 @@ let extension_descr path_ext ext =
       | None -> newgenconstr ext.ext_type_path ext.ext_type_params
   in
   let existentials, cstr_args, cstr_inlined =
-    constructor_args ext.ext_args ext.ext_ret_type
+    constructor_args ext.ext_private ext.ext_args ext.ext_ret_type
       path_ext Record_extension
   in
     { cstr_name = Path.last path_ext;
@@ -201,7 +217,7 @@ let rec find_constr tag num_const num_nonconst = function
       then c
       else find_constr tag (num_const + 1) num_nonconst rem
   | c :: rem ->
-      if tag = Cstr_block num_nonconst
+      if tag = Cstr_block num_nonconst || tag = Cstr_unboxed
       then c
       else find_constr tag num_const (num_nonconst + 1) rem
 
diff --git a/typing/datarepr.mli b/typing/datarepr.mli
index de8a8c28..8a85282a 100644
--- a/typing/datarepr.mli
+++ b/typing/datarepr.mli
@@ -34,3 +34,11 @@ exception Constr_not_found
 val find_constr_by_tag:
   constructor_tag -> constructor_declaration list ->
     constructor_declaration
+
+val constructor_existentials :
+    constructor_arguments -> type_expr option -> type_expr list * type_expr list
+(** Takes [cd_args] and [cd_res] from a [constructor_declaration] and
+    returns:
+    - the types of the constructor's arguments
+    - the existential variables introduced by the constructor
+ *)
diff --git a/typing/env.ml b/typing/env.ml
index 20e7a7ce..7a0beff0 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -35,6 +35,7 @@ let value_declarations : ((string * Location.t), (unit -> unit)) Hashtbl.t =
        cf Includemod.value_descriptions). *)
 
 let type_declarations = Hashtbl.create 16
+let module_declarations = Hashtbl.create 16
 
 type constructor_usage = Positive | Pattern | Privatize
 type constructor_usages =
@@ -60,6 +61,7 @@ type error =
   | Illegal_renaming of string * string * string
   | Inconsistent_import of string * string * string
   | Need_recursive_types of string * string
+  | Depend_on_unsafe_string_unit of string * string
   | Missing_module of Location.t * Path.t * Path.t
   | Illegal_value_name of Location.t * string
 
@@ -104,6 +106,7 @@ end  = struct
 
 end
 
+module PathMap = Map.Make(Path)
 
 type summary =
     Env_empty
@@ -116,6 +119,7 @@ type summary =
   | Env_cltype of summary * Ident.t * class_type_declaration
   | Env_open of summary * Path.t
   | Env_functor_arg of summary * Ident.t
+  | Env_constraints of summary * type_declaration PathMap.t
 
 module EnvTbl =
   struct
@@ -178,7 +182,7 @@ type t = {
   cltypes: (Path.t * class_type_declaration) EnvTbl.t;
   functor_args: unit Ident.tbl;
   summary: summary;
-  local_constraints: bool;
+  local_constraints: type_declaration PathMap.t;
   gadt_instances: (int * TypeSet.t ref) list;
   flags: int;
 }
@@ -186,6 +190,7 @@ type t = {
 and module_components =
   {
     deprecated: string option;
+    loc: Location.t;
     comps: (t * Subst.t * Path.t * Types.module_type, module_components_repr)
            EnvLazy.t;
   }
@@ -216,6 +221,12 @@ and functor_components = {
   fcomp_subst_cache: (Path.t, module_type) Hashtbl.t
 }
 
+let copy_local ~from env =
+  { env with
+    local_constraints = from.local_constraints;
+    gadt_instances = from.gadt_instances;
+    flags = from.flags }
+
 let same_constr = ref (fun _ _ _ -> assert false)
 
 (* Helper to decide whether to report an identifier shadowing
@@ -251,7 +262,7 @@ let empty = {
   modules = EnvTbl.empty; modtypes = EnvTbl.empty;
   components = EnvTbl.empty; classes = EnvTbl.empty;
   cltypes = EnvTbl.empty;
-  summary = Env_empty; local_constraints = false; gadt_instances = [];
+  summary = Env_empty; local_constraints = PathMap.empty; gadt_instances = [];
   flags = 0;
   functor_args = Ident.empty;
  }
@@ -297,23 +308,24 @@ let diff env1 env2 =
 (* Forward declarations *)
 
 let components_of_module' =
-  ref ((fun ~deprecated env sub path mty -> assert false) :
-         deprecated:string option -> t -> Subst.t -> Path.t -> module_type ->
+  ref ((fun ~deprecated:_ ~loc:__env _sub _path _mty -> assert false) :
+         deprecated:string option -> loc:Location.t -> t -> Subst.t ->
+       Path.t -> module_type ->
        module_components)
 let components_of_module_maker' =
-  ref ((fun (env, sub, path, mty) -> assert false) :
+  ref ((fun (_env, _sub, _path, _mty) -> assert false) :
           t * Subst.t * Path.t * module_type -> module_components_repr)
 let components_of_functor_appl' =
-  ref ((fun f env p1 p2 -> assert false) :
+  ref ((fun _f _env _p1 _p2 -> assert false) :
           functor_components -> t -> Path.t -> Path.t -> module_components)
 let check_modtype_inclusion =
   (* to be filled with Includemod.check_modtype_inclusion *)
-  ref ((fun env mty1 path1 mty2 -> assert false) :
+  ref ((fun _env _mty1 _path1 _mty2 -> assert false) :
           t -> module_type -> Path.t -> module_type -> unit)
 let strengthen =
   (* to be filled with Mtype.strengthen *)
-  ref ((fun env mty path -> assert false) :
-         t -> module_type -> Path.t -> module_type)
+  ref ((fun ~aliasable:_ _env _mty _path -> assert false) :
+         aliasable:bool -> t -> module_type -> Path.t -> module_type)
 
 let md md_type =
   {md_type; md_attributes=[]; md_loc=Location.none}
@@ -384,14 +396,25 @@ let save_pers_struct crc ps =
     (function
         | Rectypes -> ()
         | Deprecated _ -> ()
+        | Unsafe_string -> ()
         | Opaque -> add_imported_opaque modname)
     ps.ps_flags;
   Consistbl.set crc_units modname crc ps.ps_filename;
   add_import modname
 
-let read_pers_struct check modname filename =
-  add_import modname;
-  let cmi = read_cmi filename in
+module Persistent_signature = struct
+  type t =
+    { filename : string;
+      cmi : Cmi_format.cmi_infos }
+
+  let load = ref (fun ~unit_name ->
+    match find_in_path_uncap !load_path (unit_name ^ ".cmi") with
+    | filename -> Some { filename; cmi = read_cmi filename }
+    | exception Not_found -> None)
+end
+
+let acknowledge_pers_struct check modname
+      { Persistent_signature.filename; cmi } =
   let name = cmi.cmi_name in
   let sign = cmi.cmi_sign in
   let crcs = cmi.cmi_crcs in
@@ -401,7 +424,8 @@ let read_pers_struct check modname filename =
       flags
   in
   let comps =
-      !components_of_module' ~deprecated empty Subst.identity
+      !components_of_module' ~deprecated ~loc:Location.none
+        empty Subst.identity
                              (Pident(Ident.create_persistent name))
                              (Mty_signature sign)
   in
@@ -414,11 +438,15 @@ let read_pers_struct check modname filename =
            } in
   if ps.ps_name <> modname then
     error (Illegal_renaming(modname, ps.ps_name, filename));
+
   List.iter
     (function
         | Rectypes ->
             if not !Clflags.recursive_types then
               error (Need_recursive_types(ps.ps_name, !current_unit))
+        | Unsafe_string ->
+            if Config.safe_string then
+              error (Depend_on_unsafe_string_unit (ps.ps_name, !current_unit));
         | Deprecated _ -> ()
         | Opaque -> add_imported_opaque modname)
     ps.ps_flags;
@@ -426,20 +454,31 @@ let read_pers_struct check modname filename =
   Hashtbl.add persistent_structures modname (Some ps);
   ps
 
+let read_pers_struct check modname filename =
+  add_import modname;
+  let cmi = read_cmi filename in
+  acknowledge_pers_struct check modname
+    { Persistent_signature.filename; cmi }
+
+let can_load_cmis = ref true
+let without_cmis f x =
+  Misc.(protect_refs [R (can_load_cmis, false)] (fun () -> f x))
+
 let find_pers_struct check name =
   if name = "*predef*" then raise Not_found;
   match Hashtbl.find persistent_structures name with
   | Some ps -> ps
   | None -> raise Not_found
-  | exception Not_found ->
-      let filename =
-        try
-          find_in_path_uncap !load_path (name ^ ".cmi")
-        with Not_found ->
+  | exception Not_found when !can_load_cmis ->
+      let ps =
+        match !Persistent_signature.load ~unit_name:name with
+        | Some ps -> ps
+        | None ->
           Hashtbl.add persistent_structures name None;
           raise Not_found
       in
-      read_pers_struct check name filename
+      add_import name;
+      acknowledge_pers_struct check name ps
 
 (* Emits a warning if there is no valid cmi for name *)
 let check_pers_struct name =
@@ -466,6 +505,9 @@ let check_pers_struct name =
             Format.sprintf
               "%s uses recursive types"
               name
+        | Depend_on_unsafe_string_unit (name, _) ->
+            Printf.sprintf "%s uses -unsafe-string"
+              name
         | Missing_module _ -> assert false
         | Illegal_value_name _ -> assert false
       in
@@ -495,6 +537,7 @@ let reset_cache () =
   clear_imports ();
   Hashtbl.clear value_declarations;
   Hashtbl.clear type_declarations;
+  Hashtbl.clear module_declarations;
   Hashtbl.clear used_constructors;
   Hashtbl.clear prefixed_sg
 
@@ -508,6 +551,7 @@ let reset_cache_toplevel () =
   List.iter (Hashtbl.remove persistent_structures) l;
   Hashtbl.clear value_declarations;
   Hashtbl.clear type_declarations;
+  Hashtbl.clear module_declarations;
   Hashtbl.clear used_constructors;
   Hashtbl.clear prefixed_sg
 
@@ -524,42 +568,42 @@ let rec find_module_descr path env =
   match path with
     Pident id ->
       begin try
-        let (p, desc) = EnvTbl.find_same id env.components
+        let (_p, desc) = EnvTbl.find_same id env.components
         in desc
       with Not_found ->
         if Ident.persistent id && not (Ident.name id = !current_unit)
         then (find_pers_struct (Ident.name id)).ps_comps
         else raise Not_found
       end
-  | Pdot(p, s, pos) ->
+  | Pdot(p, s, _pos) ->
       begin match get_components (find_module_descr p env) with
         Structure_comps c ->
-          let (descr, pos) = Tbl.find s c.comp_components in
+          let (descr, _pos) = Tbl.find s c.comp_components in
           descr
-      | Functor_comps f ->
+      | Functor_comps _ ->
          raise Not_found
       end
   | Papply(p1, p2) ->
       begin match get_components (find_module_descr p1 env) with
         Functor_comps f ->
           !components_of_functor_appl' f env p1 p2
-      | Structure_comps c ->
+      | Structure_comps _ ->
           raise Not_found
       end
 
 let find proj1 proj2 path env =
   match path with
     Pident id ->
-      let (p, data) = EnvTbl.find_same id (proj1 env)
+      let (_p, data) = EnvTbl.find_same id (proj1 env)
       in data
-  | Pdot(p, s, pos) ->
+  | Pdot(p, s, _pos) ->
       begin match get_components (find_module_descr p env) with
         Structure_comps c ->
-          let (data, pos) = Tbl.find s (proj2 c) in data
-      | Functor_comps f ->
+          let (data, _pos) = Tbl.find s (proj2 c) in data
+      | Functor_comps _ ->
           raise Not_found
       end
-  | Papply(p1, p2) ->
+  | Papply _ ->
       raise Not_found
 
 let find_value =
@@ -581,7 +625,9 @@ let type_of_cstr path = function
 
 let find_type_full path env =
   match Path.constructor_typath path with
-  | Regular p -> find_type_full p env
+  | Regular p ->
+      (try (PathMap.find p env.local_constraints, ([], []))
+       with Not_found -> find_type_full p env)
   | Cstr (ty_path, s) ->
       let (_, (cstrs, _)) =
         try find_type_full ty_path env
@@ -627,7 +673,7 @@ let find_module ~alias path env =
   match path with
     Pident id ->
       begin try
-        let (p, data) = EnvTbl.find_same id env.modules
+        let (_p, data) = EnvTbl.find_same id env.modules
         in data
       with Not_found ->
         if Ident.persistent id && not (Ident.name id = !current_unit) then
@@ -635,12 +681,12 @@ let find_module ~alias path env =
           md (Mty_signature(Lazy.force ps.ps_sig))
         else raise Not_found
       end
-  | Pdot(p, s, pos) ->
+  | Pdot(p, s, _pos) ->
       begin match get_components (find_module_descr p env) with
         Structure_comps c ->
-          let (data, pos) = Tbl.find s c.comp_modules in
+          let (data, _pos) = Tbl.find s c.comp_modules in
           md (EnvLazy.force subst_modtype_maker data)
-      | Functor_comps f ->
+      | Functor_comps _ ->
           raise Not_found
       end
   | Papply(p1, p2) ->
@@ -648,7 +694,7 @@ let find_module ~alias path env =
       begin match get_components desc1 with
         Functor_comps f ->
           md begin match f.fcomp_res with
-          | Mty_alias p as mty-> mty
+          | Mty_alias _ as mty -> mty
           | mty ->
               if alias then mty else
               try
@@ -661,7 +707,7 @@ let find_module ~alias path env =
                 Hashtbl.add f.fcomp_subst_cache p2 mty;
                 mty
           end
-      | Structure_comps c ->
+      | Structure_comps _ ->
           raise Not_found
       end
 
@@ -683,7 +729,7 @@ let rec normalize_path lax env path =
     | _ -> path
   in
   try match find_module ~alias:true path env with
-    {md_type=Mty_alias path1} ->
+    {md_type=Mty_alias(_, path1)} ->
       let path' = normalize_path lax env path1 in
       if lax || !Clflags.transparent_modules then path' else
       let id = Path.head path in
@@ -702,6 +748,16 @@ let normalize_path oloc env path =
     | Some loc ->
         raise (Error(Missing_module(loc, path, normalize_path true env path)))
 
+let normalize_path_prefix oloc env path =
+  match path with
+    Pdot(p, s, pos) ->
+      Pdot(normalize_path oloc env p, s, pos)
+  | Pident _ ->
+      path
+  | Papply _ ->
+      assert false
+
+
 let find_module = find_module ~alias:false
 
 (* Find the manifest type associated to a type when appropriate:
@@ -718,13 +774,7 @@ let find_type_expansion path env =
      private row are still considered unknown to the type system.
      Hence, this case is caught by the following clause that also handles
      purely abstract data types without manifest type definition. *)
-  | _ ->
-      (* another way to expand is to normalize the path itself *)
-      let path' = normalize_path None env path in
-      if Path.same path path' then raise Not_found else
-      (decl.type_params,
-       newgenty (Tconstr (path', decl.type_params, ref Mnil)),
-       may_map snd decl.type_newtype_level)
+  | _ -> raise Not_found
 
 (* Find the manifest type information associated to a type, i.e.
    the necessary information for the compiler's type-based optimisations.
@@ -736,12 +786,7 @@ let find_type_expansion_opt path env =
   (* The manifest type of Private abstract data types can still get
      an approximation using their manifest type. *)
   | Some body -> (decl.type_params, body, may_map snd decl.type_newtype_level)
-  | _ ->
-      let path' = normalize_path None env path in
-      if Path.same path path' then raise Not_found else
-      (decl.type_params,
-       newgenty (Tconstr (path', decl.type_params, ref Mnil)),
-       may_map snd decl.type_newtype_level)
+  | _ -> raise Not_found
 
 let find_modtype_expansion path env =
   match (find_modtype path env).mtd_type with
@@ -754,7 +799,7 @@ let rec is_functor_arg path env =
       begin try Ident.find_same id env.functor_args; true
       with Not_found -> false
       end
-  | Pdot (p, s, _) -> is_functor_arg p env
+  | Pdot (p, _s, _) -> is_functor_arg p env
   | Papply _ -> true
 
 (* Lookup by name *)
@@ -770,6 +815,11 @@ let report_deprecated ?loc p deprecated =
                                 (Path.name p) txt))
   | _ -> ()
 
+let mark_module_used env name loc =
+  if not (is_implicit_coercion env) then
+    try Hashtbl.find module_declarations (name, loc) ()
+    with Not_found -> ()
+
 let rec lookup_module_descr_aux ?loc lid env =
   match lid with
     Lident s ->
@@ -786,7 +836,7 @@ let rec lookup_module_descr_aux ?loc lid env =
         Structure_comps c ->
           let (descr, pos) = Tbl.find s c.comp_components in
           (Pdot(p, s, pos), descr)
-      | Functor_comps f ->
+      | Functor_comps _ ->
           raise Not_found
       end
   | Lapply(l1, l2) ->
@@ -797,12 +847,17 @@ let rec lookup_module_descr_aux ?loc lid env =
         Functor_comps f ->
           Misc.may (!check_modtype_inclusion env mty2 p2) f.fcomp_arg;
           (Papply(p1, p2), !components_of_functor_appl' f env p1 p2)
-      | Structure_comps c ->
+      | Structure_comps _ ->
           raise Not_found
       end
 
 and lookup_module_descr ?loc lid env =
   let (p, comps) as res = lookup_module_descr_aux ?loc lid env in
+  mark_module_used env (Path.last p) comps.loc;
+(*
+  Format.printf "USE module %s at %a@." (Path.last p)
+    Location.print comps.loc;
+*)
   report_deprecated ?loc p comps.deprecated;
   res
 
@@ -810,7 +865,10 @@ and lookup_module ~load ?loc lid env : Path.t =
   match lid with
     Lident s ->
       begin try
-        let (p, {md_type; md_attributes}) = EnvTbl.find_name s env.modules in
+        let (p, {md_type; md_attributes; md_loc}) =
+          EnvTbl.find_name s env.modules
+        in
+        mark_module_used env s md_loc;
         begin match md_type with
         | Mty_ident (Path.Pident id) when Ident.name id = "#recmod#" ->
           (* see #5965 *)
@@ -834,12 +892,13 @@ and lookup_module ~load ?loc lid env : Path.t =
       let (p, descr) = lookup_module_descr ?loc l env in
       begin match get_components descr with
         Structure_comps c ->
-          let (data, pos) = Tbl.find s c.comp_modules in
+          let (_data, pos) = Tbl.find s c.comp_modules in
           let (comps, _) = Tbl.find s c.comp_components in
+          mark_module_used env s comps.loc;
           let p = Pdot(p, s, pos) in
           report_deprecated ?loc p comps.deprecated;
           p
-      | Functor_comps f ->
+      | Functor_comps _ ->
           raise Not_found
       end
   | Lapply(l1, l2) ->
@@ -851,7 +910,7 @@ and lookup_module ~load ?loc lid env : Path.t =
         Functor_comps f ->
           Misc.may (!check_modtype_inclusion env mty2 p2) f.fcomp_arg;
           p
-      | Structure_comps c ->
+      | Structure_comps _ ->
           raise Not_found
       end
 
@@ -865,10 +924,10 @@ let lookup proj1 proj2 ?loc lid env =
         Structure_comps c ->
           let (data, pos) = Tbl.find s (proj2 c) in
           (Pdot(p, s, pos), data)
-      | Functor_comps f ->
+      | Functor_comps _ ->
           raise Not_found
       end
-  | Lapply(l1, l2) ->
+  | Lapply _ ->
       raise Not_found
 
 let lookup_all_simple proj1 proj2 shadow ?loc lid env =
@@ -880,33 +939,33 @@ let lookup_all_simple proj1 proj2 shadow ?loc lid env =
         | [] -> []
         | ((x, f) :: xs) ->
             (x, f) ::
-              (do_shadow (List.filter (fun (y, g) -> not (shadow x y)) xs))
+              (do_shadow (List.filter (fun (y, _) -> not (shadow x y)) xs))
       in
         do_shadow xl
   | Ldot(l, s) ->
-      let (p, desc) = lookup_module_descr ?loc l env in
+      let (_p, desc) = lookup_module_descr ?loc l env in
       begin match get_components desc with
         Structure_comps c ->
           let comps =
             try Tbl.find s (proj2 c) with Not_found -> []
           in
           List.map
-            (fun (data, pos) -> (data, (fun () -> ())))
+            (fun (data, _pos) -> (data, (fun () -> ())))
             comps
-      | Functor_comps f ->
+      | Functor_comps _ ->
           raise Not_found
       end
-  | Lapply(l1, l2) ->
+  | Lapply _ ->
       raise Not_found
 
-let has_local_constraints env = env.local_constraints
+let has_local_constraints env = not (PathMap.is_empty env.local_constraints)
 
 let cstr_shadow cstr1 cstr2 =
   match cstr1.cstr_tag, cstr2.cstr_tag with
   | Cstr_extension _, Cstr_extension _ -> true
   | _ -> false
 
-let lbl_shadow lbl1 lbl2 = false
+let lbl_shadow _lbl1 _lbl2 = false
 
 let lookup_value =
   lookup (fun env -> env.values) (fun sc -> sc.comp_values)
@@ -989,7 +1048,7 @@ let lookup_value ?loc lid env =
 let lookup_type ?loc lid env =
   let (path, (decl, _)) = lookup_type ?loc lid env in
   mark_type_used env (Longident.last lid) decl;
-  (path, decl)
+  path
 
 let mark_type_path env path =
   try
@@ -1082,10 +1141,10 @@ let iter_env_cont = ref []
 
 let rec scrape_alias_for_visit env mty =
   match mty with
-  | Mty_alias (Pident id)
+  | Mty_alias(_, Pident id)
     when Ident.persistent id
       && not (Hashtbl.mem persistent_structures (Ident.name id)) -> false
-  | Mty_alias path -> (* PR#6600: find_module may raise Not_found *)
+  | Mty_alias(_, path) -> (* PR#6600: find_module may raise Not_found *)
       begin try scrape_alias_for_visit env (find_module path env).md_type
       with Not_found -> false
       end
@@ -1098,7 +1157,7 @@ let iter_env proj1 proj2 f env () =
       let visit =
         match EnvLazy.get_arg mcomps.comps with
         | None -> true
-        | Some (env, sub, path, mty) -> scrape_alias_for_visit env mty
+        | Some (env, _sub, _path, mty) -> scrape_alias_for_visit env mty
       in
       if not visit then () else
       match get_components mcomps with
@@ -1233,7 +1292,7 @@ let rec scrape_alias env ?path mty =
       with Not_found ->
         mty
       end
-  | Mty_alias path, _ ->
+  | Mty_alias(_, path), _ ->
       begin try
         scrape_alias env (find_module path env).md_type ~path
       with Not_found ->
@@ -1242,7 +1301,7 @@ let rec scrape_alias env ?path mty =
         mty
       end
   | mty, Some path ->
-      !strengthen env mty path
+      !strengthen ~aliasable:true env mty path
   | _ -> mty
 
 let scrape_alias env mty = scrape_alias env mty
@@ -1257,35 +1316,35 @@ let rec prefix_idents root pos sub = function
       let nextpos = match decl.val_kind with Val_prim _ -> pos | _ -> pos+1 in
       let (pl, final_sub) = prefix_idents root nextpos sub rem in
       (p::pl, final_sub)
-  | Sig_type(id, decl, _) :: rem ->
+  | Sig_type(id, _, _) :: rem ->
       let p = Pdot(root, Ident.name id, nopos) in
       let (pl, final_sub) =
         prefix_idents root pos (Subst.add_type id p sub) rem in
       (p::pl, final_sub)
-  | Sig_typext(id, ext, _) :: rem ->
+  | Sig_typext(id, _, _) :: rem ->
       let p = Pdot(root, Ident.name id, pos) in
       (* we extend the substitution in case of an inlined record *)
       let (pl, final_sub) =
         prefix_idents root (pos+1) (Subst.add_type id p sub) rem in
       (p::pl, final_sub)
-  | Sig_module(id, mty, _) :: rem ->
+  | Sig_module(id, _, _) :: rem ->
       let p = Pdot(root, Ident.name id, pos) in
       let (pl, final_sub) =
         prefix_idents root (pos+1) (Subst.add_module id p sub) rem in
       (p::pl, final_sub)
-  | Sig_modtype(id, decl) :: rem ->
+  | Sig_modtype(id, _) :: rem ->
       let p = Pdot(root, Ident.name id, nopos) in
       let (pl, final_sub) =
         prefix_idents root pos
                       (Subst.add_modtype id (Mty_ident p) sub) rem in
       (p::pl, final_sub)
-  | Sig_class(id, decl, _) :: rem ->
+  | Sig_class(id, _, _) :: rem ->
       (* pretend this is a type, cf. PR#6650 *)
       let p = Pdot(root, Ident.name id, pos) in
       let (pl, final_sub) =
         prefix_idents root (pos + 1) (Subst.add_type id p sub) rem in
       (p::pl, final_sub)
-  | Sig_class_type(id, decl, _) :: rem ->
+  | Sig_class_type(id, _, _) :: rem ->
       let p = Pdot(root, Ident.name id, nopos) in
       let (pl, final_sub) =
         prefix_idents root pos (Subst.add_type id p sub) rem in
@@ -1318,7 +1377,7 @@ let prefix_idents_and_subst root sub sg =
   pl, sub, lazy (subst_signature sub sg)
 
 let set_nongen_level sub path =
-  Subst.set_nongen_level sub (Path.binding_time path)
+  Subst.set_nongen_level sub (Path.binding_time path - 1)
 
 let prefix_idents_and_subst root sub sg =
   let sub = set_nongen_level sub root in
@@ -1347,9 +1406,10 @@ let add_to_tbl id decl tbl =
     try Tbl.find id tbl with Not_found -> [] in
   Tbl.add id (decl :: decls) tbl
 
-let rec components_of_module ~deprecated env sub path mty =
+let rec components_of_module ~deprecated ~loc env sub path mty =
   {
     deprecated;
+    loc;
     comps = EnvLazy.create (env, sub, path, mty)
   }
 
@@ -1410,10 +1470,12 @@ and components_of_module_maker (env, sub, path, mty) =
             let deprecated =
               Builtin_attributes.deprecated_of_attrs md.md_attributes
             in
-            let comps = components_of_module ~deprecated !env sub path mty in
+            let comps =
+              components_of_module ~deprecated ~loc:md.md_loc !env sub path mty
+            in
             c.comp_components <-
               Tbl.add (Ident.name id) (comps, !pos) c.comp_components;
-            env := store_module None id (Pident id) md !env !env;
+            env := store_module ~check:false None id (Pident id) md !env !env;
             incr pos
         | Sig_modtype(id, decl) ->
             let decl' = Subst.modtype_declaration sub decl in
@@ -1548,8 +1610,9 @@ and store_type_infos slot id path info env renv =
 and store_extension ~check slot id path ext env renv =
   let loc = ext.ext_loc in
   if check && not loc.Location.loc_ghost &&
-    Warnings.is_active (Warnings.Unused_extension ("", false, false))
+    Warnings.is_active (Warnings.Unused_extension ("", false, false, false))
   then begin
+    let is_exception = Path.same ext.ext_type_path Predef.path_exn in
     let ty = Path.last ext.ext_type_path in
     let n = Ident.name id in
     let k = (ty, loc, n) in
@@ -1561,7 +1624,7 @@ and store_extension ~check slot id path ext env renv =
           if not (is_in_signature env) && not used.cu_positive then
             Location.prerr_warning loc
               (Warnings.Unused_extension
-                 (n, used.cu_pattern, used.cu_privatize)
+                 (n, is_exception, used.cu_pattern, used.cu_privatize)
               )
         )
     end;
@@ -1572,14 +1635,19 @@ and store_extension ~check slot id path ext env renv =
                 env.constrs renv.constrs;
     summary = Env_extension(env.summary, id, ext) }
 
-and store_module slot id path md env renv =
+and store_module ~check slot id path md env renv =
+  let loc = md.md_loc in
+  if check then
+    check_usage loc id (fun s -> Warnings.Unused_module s)
+      module_declarations;
+
   let deprecated = Builtin_attributes.deprecated_of_attrs md.md_attributes in
   { env with
     modules = EnvTbl.add slot (fun x -> `Module x) id (path, md)
         env.modules renv.modules;
     components =
       EnvTbl.add slot (fun x -> `Component x) id
-        (path, components_of_module ~deprecated
+        (path, components_of_module ~deprecated ~loc:md.md_loc
            env Subst.identity path md.md_type)
         env.components renv.components;
     summary = Env_module(env.summary, id, md) }
@@ -1611,7 +1679,8 @@ let components_of_functor_appl f env p1 p2 =
     let p = Papply(p1, p2) in
     let sub = Subst.add_module f.fcomp_param p2 Subst.identity in
     let mty = Subst.modtype sub f.fcomp_res in
-    let comps = components_of_module ~deprecated:None (*???*)
+    let comps = components_of_module ~deprecated:None ~loc:Location.none
+        (*???*)
         env Subst.identity p mty in
     Hashtbl.add f.fcomp_cache p2 comps;
     comps
@@ -1639,13 +1708,13 @@ let add_type ~check id info env =
 and add_extension ~check id ext env =
   store_extension ~check None id (Pident id) ext env env
 
-and add_module_declaration ?(arg=false) id md env =
+and add_module_declaration ?(arg=false) ~check id md env =
   let path =
     (*match md.md_type with
       Mty_alias path -> normalize_path env path
     | _ ->*) Pident id
   in
-  let env = store_module None id path md env env in
+  let env = store_module ~check None id path md env env in
   if arg then add_functor_arg id env else env
 
 and add_modtype id info env =
@@ -1658,18 +1727,21 @@ and add_cltype id ty env =
   store_cltype None id (Pident id) ty env env
 
 let add_module ?arg id mty env =
-  add_module_declaration ?arg id (md mty) env
+  add_module_declaration ~check:false ?arg id (md mty) env
 
-let add_local_constraint id info elv env =
+let add_local_type path info env =
+  { env with
+    local_constraints = PathMap.add path info env.local_constraints }
+
+let add_local_constraint path info elv env =
   match info with
-    {type_manifest = Some ty; type_newtype_level = Some (lv, _)} ->
+    {type_manifest = Some _; type_newtype_level = Some (lv, _)} ->
       (* elv is the expansion level, lv is the definition level *)
-      let env =
-        add_type ~check:false
-          id {info with type_newtype_level = Some (lv, elv)} env in
-      { env with local_constraints = true }
+      let info = {info with type_newtype_level = Some (lv, elv)} in
+      add_local_type path info env
   | _ -> assert false
 
+
 (* Insertion of bindings by name *)
 
 let enter store_fun name data env =
@@ -1679,7 +1751,7 @@ let enter_value ?check = enter (store_value ?check)
 and enter_type = enter (store_type ~check:true)
 and enter_extension = enter (store_extension ~check:true)
 and enter_module_declaration ?arg id md env =
-  add_module_declaration ?arg id md env
+  add_module_declaration ?arg ~check:true id md env
   (* let (id, env) = enter store_module name md env in
   (id, add_functor_arg ?arg id env) *)
 and enter_modtype = enter store_modtype
@@ -1697,7 +1769,7 @@ let add_item comp env =
     Sig_value(id, decl)     -> add_value id decl env
   | Sig_type(id, decl, _)   -> add_type ~check:false id decl env
   | Sig_typext(id, ext, _)  -> add_extension ~check:false id ext env
-  | Sig_module(id, md, _)   -> add_module_declaration id md env
+  | Sig_module(id, md, _)   -> add_module_declaration ~check:false id md env
   | Sig_modtype(id, decl)   -> add_modtype id decl env
   | Sig_class(id, decl, _)  -> add_class id decl env
   | Sig_class_type(id, decl, _) -> add_cltype id decl env
@@ -1711,7 +1783,7 @@ let rec add_signature sg env =
 
 let open_signature slot root sg env0 =
   (* First build the paths and substitution *)
-  let (pl, sub, sg) = prefix_idents_and_subst root Subst.identity sg in
+  let (pl, _sub, sg) = prefix_idents_and_subst root Subst.identity sg in
   let sg = Lazy.force sg in
 
   (* Then enter the components in the environment after substitution *)
@@ -1727,7 +1799,7 @@ let open_signature slot root sg env0 =
         | Sig_typext(id, ext, _) ->
             store_extension ~check:false slot (Ident.hide id) p ext env env0
         | Sig_module(id, mty, _) ->
-            store_module slot (Ident.hide id) p mty env env0
+            store_module ~check:false slot (Ident.hide id) p mty env env0
         | Sig_modtype(id, decl) ->
             store_modtype slot (Ident.hide id) p decl env env0
         | Sig_class(id, decl, _) ->
@@ -1818,6 +1890,7 @@ let save_signature_with_imports ~deprecated sg modname filename imports =
     List.concat [
       if !Clflags.recursive_types then [Cmi_format.Rectypes] else [];
       if !Clflags.opaque then [Cmi_format.Opaque] else [];
+      (if !Clflags.unsafe_string then [Cmi_format.Unsafe_string] else []);
       (match deprecated with Some s -> [Deprecated s] | None -> []);
     ]
   in
@@ -1834,7 +1907,8 @@ let save_signature_with_imports ~deprecated sg modname filename imports =
     (* Enter signature in persistent table so that imported_unit()
        will also return its crc *)
     let comps =
-      components_of_module ~deprecated empty Subst.identity
+      components_of_module ~deprecated ~loc:Location.none
+        empty Subst.identity
         (Pident(Ident.create_persistent modname)) (Mty_signature sg) in
     let ps =
       { ps_name = modname;
@@ -1877,17 +1951,17 @@ let find_all_simple_list proj1 proj2 f lid env acc =
   match lid with
     | None ->
       EnvTbl.fold_name
-        (fun id data acc -> f data acc)
+        (fun _id data acc -> f data acc)
         (proj1 env) acc
     | Some l ->
-      let p, desc = lookup_module_descr l env in
+      let (_p, desc) = lookup_module_descr l env in
       begin match get_components desc with
           Structure_comps c ->
             Tbl.fold
-              (fun s comps acc ->
+              (fun _s comps acc ->
                 match comps with
                   [] -> acc
-                | (data, pos) :: _ ->
+                | (data, _pos) :: _ ->
                   f data acc)
               (proj2 c) acc
         | Functor_comps _ ->
@@ -1951,7 +2025,9 @@ let (initial_safe_string, initial_unsafe_string) =
 
 (* Return the environment summary *)
 
-let summary env = env.summary
+let summary env =
+  if PathMap.is_empty env.local_constraints then env.summary
+  else Env_constraints (env.summary, env.local_constraints)
 
 let last_env = ref empty
 let last_reduced_env = ref empty
@@ -1997,6 +2073,11 @@ let report_error ppf = function
       fprintf ppf
         "@[Unit %s imports from %s, which uses recursive types.@ %s@]"
         export import "The compilation flag -rectypes is required"
+  | Depend_on_unsafe_string_unit(import, export) ->
+      fprintf ppf
+        "@[Unit %s imports from %s, compiled with -unsafe-string.@ %s@]"
+        export import "This compiler has been configured in strict \
+                       -safe-string mode"
   | Missing_module(_, path1, path2) ->
       fprintf ppf "@[@[";
       if Path.same path1 path2 then
diff --git a/typing/env.mli b/typing/env.mli
index 8166db82..aa57630d 100644
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -17,6 +17,9 @@
 
 open Types
 
+module PathMap : Map.S with type key = Path.t
+                        and type 'a t = 'a Map.Make(Path).t
+
 type summary =
     Env_empty
   | Env_value of summary * Ident.t * value_description
@@ -28,6 +31,7 @@ type summary =
   | Env_cltype of summary * Ident.t * class_type_declaration
   | Env_open of summary * Path.t
   | Env_functor_arg of summary * Ident.t
+  | Env_constraints of summary * type_declaration PathMap.t
 
 type t
 
@@ -35,6 +39,7 @@ val empty: t
 val initial_safe_string: t
 val initial_unsafe_string: t
 val diff: t -> t -> Ident.t list
+val copy_local: from:t -> t -> t
 
 type type_descriptions =
     constructor_description list * label_description list
@@ -48,6 +53,9 @@ val run_iter_cont: iter_cont list -> (Path.t * iter_cont) list
 val same_types: t -> t -> bool
 val used_persistent: unit -> Concr.t
 val find_shadowed_types: Path.t -> t -> Path.t list
+val without_cmis: ('a -> 'b) -> 'a -> 'b
+        (* [without_cmis f arg] applies [f] to [arg], but does not
+           allow opening cmis during its execution *)
 
 (* Lookup by paths *)
 
@@ -73,6 +81,8 @@ val normalize_path: Location.t option -> t -> Path.t -> Path.t
    If the option is None, allow returning dangling paths.
    Otherwise raise a Missing_module error, and may add forgotten
    head as required global. *)
+val normalize_path_prefix: Location.t option -> t -> Path.t -> Path.t
+(* Only normalize the prefix part of the path *)
 val reset_required_globals: unit -> unit
 val get_required_globals: unit -> Ident.t list
 val add_required_global: Ident.t -> unit
@@ -100,7 +110,10 @@ val lookup_all_labels:
   ?loc:Location.t ->
   Longident.t -> t -> (label_description * (unit -> unit)) list
 val lookup_type:
-  ?loc:Location.t -> Longident.t -> t -> Path.t * type_declaration
+  ?loc:Location.t -> Longident.t -> t -> Path.t
+  (* Since 4.04, this function no longer returns [type_description].
+     To obtain it, you should either call [Env.find_type], or replace
+     it by [Typetexp.find_type] *)
 val lookup_module:
   load:bool -> ?loc:Location.t -> Longident.t -> t -> Path.t
 val lookup_modtype:
@@ -126,11 +139,13 @@ val add_value:
 val add_type: check:bool -> Ident.t -> type_declaration -> t -> t
 val add_extension: check:bool -> Ident.t -> extension_constructor -> t -> t
 val add_module: ?arg:bool -> Ident.t -> module_type -> t -> t
-val add_module_declaration: ?arg:bool -> Ident.t -> module_declaration -> t -> t
+val add_module_declaration: ?arg:bool -> check:bool -> Ident.t ->
+  module_declaration -> t -> t
 val add_modtype: Ident.t -> modtype_declaration -> t -> t
 val add_class: Ident.t -> class_declaration -> t -> t
 val add_cltype: Ident.t -> class_type_declaration -> t -> t
-val add_local_constraint: Ident.t -> type_declaration -> int -> t -> t
+val add_local_constraint: Path.t -> type_declaration -> int -> t -> t
+val add_local_type: Path.t -> type_declaration -> t -> t
 
 (* Insertion of all fields of a signature. *)
 
@@ -217,6 +232,7 @@ type error =
   | Illegal_renaming of string * string * string
   | Inconsistent_import of string * string * string
   | Need_recursive_types of string * string
+  | Depend_on_unsafe_string_unit of string * string
   | Missing_module of Location.t * Path.t * Path.t
   | Illegal_value_name of Location.t * string
 
@@ -228,6 +244,7 @@ val report_error: formatter -> error -> unit
 
 
 val mark_value_used: t -> string -> value_description -> unit
+val mark_module_used: t -> string -> Location.t -> unit
 val mark_type_used: t -> string -> type_declaration -> unit
 
 type constructor_usage = Positive | Pattern | Privatize
@@ -254,7 +271,8 @@ val check_modtype_inclusion:
 (* Forward declaration to break mutual recursion with Typecore. *)
 val add_delayed_check_forward: ((unit -> unit) -> unit) ref
 (* Forward declaration to break mutual recursion with Mtype. *)
-val strengthen: (t -> module_type -> Path.t -> module_type) ref
+val strengthen:
+    (aliasable:bool -> t -> module_type -> Path.t -> module_type) ref
 (* Forward declaration to break mutual recursion with Ctype. *)
 val same_constr: (t -> type_expr -> type_expr -> bool) ref
 
@@ -291,3 +309,14 @@ val fold_cltypes:
 (** Utilities *)
 val scrape_alias: t -> module_type -> module_type
 val check_value_name: string -> Location.t -> unit
+
+module Persistent_signature : sig
+  type t =
+    { filename : string; (** Name of the file containing the signature. *)
+      cmi : Cmi_format.cmi_infos }
+
+  (** Function used to load a persistent signature. The default is to look for
+      the .cmi file in the load path. This function can be overridden to load
+      it from memory, for instance to build a self-contained toplevel. *)
+  val load : (unit_name:string -> t option) ref
+end
diff --git a/typing/envaux.ml b/typing/envaux.ml
index b83046c3..53f4d887 100644
--- a/typing/envaux.ml
+++ b/typing/envaux.ml
@@ -55,7 +55,7 @@ let rec env_from_summary sum subst =
             (Subst.extension_constructor subst desc)
             (env_from_summary s subst)
       | Env_module(s, id, desc) ->
-          Env.add_module_declaration id
+          Env.add_module_declaration ~check:false id
             (Subst.module_declaration subst desc)
             (env_from_summary s subst)
       | Env_modtype(s, id, desc) ->
@@ -79,9 +79,16 @@ let rec env_from_summary sum subst =
           Env.open_signature Asttypes.Override path'
             (extract_sig env md.md_type) env
       | Env_functor_arg(Env_module(s, id, desc), id') when Ident.same id id' ->
-          Env.add_module_declaration id (Subst.module_declaration subst desc)
+          Env.add_module_declaration ~check:false
+            id (Subst.module_declaration subst desc)
             ~arg:true (env_from_summary s subst)
       | Env_functor_arg _ -> assert false
+      | Env_constraints(s, map) ->
+          PathMap.fold
+            (fun path info ->
+              Env.add_local_type (Subst.type_path subst path)
+                (Subst.type_declaration subst info))
+            map (env_from_summary s subst)
     in
       Hashtbl.add env_cache (sum, subst) env;
       env
diff --git a/typing/ident.mli b/typing/ident.mli
index 1c9b6e04..52dd54ea 100644
--- a/typing/ident.mli
+++ b/typing/ident.mli
@@ -17,6 +17,14 @@
 
 type t = { stamp: int; name: string; mutable flags: int }
 
+include Identifiable.S with type t := t
+(* Notes:
+   - [equal] compares identifiers by name
+   - [compare x y] is 0 if [same x y] is true.
+   - [compare] compares identifiers by binding location
+*)
+
+
 val create: string -> t
 val create_persistent: string -> t
 val create_predef_exn: string -> t
@@ -25,8 +33,6 @@ val name: t -> string
 val unique_name: t -> string
 val unique_toplevel_name: t -> string
 val persistent: t -> bool
-val equal: t -> t -> bool
-        (* Compare identifiers by name. *)
 val same: t -> t -> bool
         (* Compare identifiers by binding location.
            Two identifiers are the same either if they are both
@@ -34,17 +40,12 @@ val same: t -> t -> bool
            [new], or if they are both persistent and have the same
            name. *)
 val compare: t -> t -> int
-        (* [compare x y] is 0 if [same x y] is true. *)
-val hash: t -> int
 val hide: t -> t
         (* Return an identifier with same name as the given identifier,
            but stamp different from any stamp returned by new.
            When put in a 'a tbl, this identifier can only be looked
            up by name. *)
 
-val compare : t -> t -> int
-(* Compare identifiers by binding location *)
-
 val make_global: t -> unit
 val global: t -> bool
 val is_predef_exn: t -> bool
@@ -54,9 +55,6 @@ val current_time: unit -> int
 val set_current_time: int -> unit
 val reinit: unit -> unit
 
-val print: Format.formatter -> t -> unit
-val output : out_channel -> t -> unit
-
 type 'a tbl
         (* Association tables from identifiers to type 'a. *)
 
@@ -73,5 +71,3 @@ val iter: (t -> 'a -> unit) -> 'a tbl -> unit
 (* Idents for sharing keys *)
 
 val make_key_generator : unit -> (t -> t)
-
-include Identifiable.S with type t := t
diff --git a/typing/includeclass.ml b/typing/includeclass.ml
index 92e06f1b..10748bff 100644
--- a/typing/includeclass.ml
+++ b/typing/includeclass.ml
@@ -47,7 +47,7 @@ let include_err ppf =
   function
   | CM_Virtual_class ->
       fprintf ppf "A class cannot be changed from virtual to concrete"
-  | CM_Parameter_arity_mismatch (ls, lp) ->
+  | CM_Parameter_arity_mismatch _ ->
       fprintf ppf
         "The classes do not have the same number of type parameters"
   | CM_Type_parameter_mismatch (env, trace) ->
diff --git a/typing/includecore.ml b/typing/includecore.ml
index a1bc3bdc..382a33d6 100644
--- a/typing/includecore.ml
+++ b/typing/includecore.ml
@@ -33,7 +33,7 @@ let value_descriptions env vd1 vd2 =
           let pc = {pc_desc = p; pc_type = vd2.Types.val_type;
                   pc_env = env; pc_loc = vd1.Types.val_loc; } in
           Tcoerce_primitive pc
-      | (_, Val_prim p) -> raise Dont_match
+      | (_, Val_prim _) -> raise Dont_match
       | (_, _) -> Tcoerce_none
   end else
     raise Dont_match
@@ -51,7 +51,7 @@ let private_flags decl1 decl2 =
 
 let is_absrow env ty =
   match ty.desc with
-    Tconstr(Pident id, _, _) ->
+    Tconstr(Pident _, _, _) ->
       begin match Ctype.expand_head env ty with
         {desc=Tobject _|Tvariant _} -> true
       | _ -> false
@@ -98,7 +98,7 @@ let type_manifest env ty1 params1 ty2 params2 priv2 =
       Ctype.equal env true (ty1::params1) (rest2::params2) &&
       let (fields1,rest1) = Ctype.flatten_fields fi1 in
       (match rest1 with {desc=Tnil|Tvar _|Tconstr _} -> true | _ -> false) &&
-      let pairs, miss1, miss2 = Ctype.associate_fields fields1 fields2 in
+      let pairs, _miss1, miss2 = Ctype.associate_fields fields1 fields2 in
       miss2 = [] &&
       let tl1, tl2 =
         List.split (List.map (fun (_,_,t1,_,t2) -> t1, t2) pairs) in
@@ -126,7 +126,8 @@ type type_mismatch =
   | Field_arity of Ident.t
   | Field_names of int * Ident.t * Ident.t
   | Field_missing of bool * Ident.t
-  | Record_representation of bool
+  | Record_representation of bool   (* true means second one is unboxed float *)
+  | Unboxed_representation of bool  (* true means second one is unboxed *)
   | Immediate
 
 let report_type_mismatch0 first second decl ppf err =
@@ -154,6 +155,10 @@ let report_type_mismatch0 first second decl ppf err =
       pr "Their internal representations differ:@ %s %s %s"
         (if b then second else first) decl
         "uses unboxed float representation"
+  | Unboxed_representation b ->
+      pr "Their internal representations differ:@ %s %s %s"
+         (if b then second else first) decl
+         "uses unboxed representation"
   | Immediate -> pr "%s is not an immediate type" first
 
 let report_type_mismatch first second decl ppf =
@@ -166,9 +171,9 @@ let rec compare_constructor_arguments env cstr params1 params2 arg1 arg2 =
   match arg1, arg2 with
   | Types.Cstr_tuple arg1, Types.Cstr_tuple arg2 ->
       if List.length arg1 <> List.length arg2 then [Field_arity cstr]
-      else if Misc.for_all2
-          (fun ty1 ty2 -> Ctype.equal env true (ty1::params1) (ty2::params2))
-          (arg1) (arg2)
+      else if
+        (* Ctype.equal must be called on all arguments at once, cf. PR#7378 *)
+        Ctype.equal env true (params1 @ arg1) (params2 @ arg2)
       then [] else [Field_type cstr]
   | Types.Cstr_record l1, Types.Cstr_record l2 ->
       compare_records env params1 params2 0 l1 l2
@@ -212,7 +217,8 @@ and compare_records env params1 params2 n labels1 labels2 =
       else if mut1 <> mut2 then [Field_mutable lab1] else
       if Ctype.equal env true (arg1::params1)
                               (arg2::params2)
-      then compare_records env params1 params2 (n+1) rem1 rem2
+      then (* add arguments to the parameters, cf. PR#7378 *)
+        compare_records env (arg1::params1) (arg2::params2) (n+1) rem1 rem2
       else [Field_type lab1]
 
 let type_declarations ?(equality = false) env name decl1 id decl2 =
@@ -236,6 +242,15 @@ let type_declarations ?(equality = false) env name decl1 id decl2 =
         else [Constraint]
   in
   if err <> [] then err else
+  let err =
+    match (decl2.type_kind, decl1.type_unboxed.unboxed,
+           decl2.type_unboxed.unboxed) with
+    | Type_abstract, _, _ -> []
+    | _, true, false -> [Unboxed_representation false]
+    | _, false, true -> [Unboxed_representation true]
+    | _ -> []
+  in
+  if err <> [] then err else
   let err = match (decl1.type_kind, decl2.type_kind) with
       (_, Type_abstract) -> []
     | (Type_variant cstrs1, Type_variant cstrs2) ->
diff --git a/typing/includecore.mli b/typing/includecore.mli
index 17278a4a..8ddd59cd 100644
--- a/typing/includecore.mli
+++ b/typing/includecore.mli
@@ -33,6 +33,7 @@ type type_mismatch =
   | Field_names of int * Ident.t * Ident.t
   | Field_missing of bool * Ident.t
   | Record_representation of bool
+  | Unboxed_representation of bool
   | Immediate
 
 val value_descriptions:
diff --git a/typing/includemod.ml b/typing/includemod.ml
index 6f9b2eeb..f3a3caf5 100644
--- a/typing/includemod.ml
+++ b/typing/includemod.ml
@@ -227,29 +227,50 @@ let rec modtypes env cxt subst mty1 mty2 =
 
 and try_modtypes env cxt subst mty1 mty2 =
   match (mty1, mty2) with
-  | (Mty_alias p1, Mty_alias p2) ->
+  | (Mty_alias(pres1, p1), Mty_alias(pres2, p2)) -> begin
       if Env.is_functor_arg p2 env then
         raise (Error[cxt, env, Invalid_module_alias p2]);
-      if Path.same p1 p2 then Tcoerce_none else
-      let p1 = Env.normalize_path None env p1
-      and p2 = Env.normalize_path None env (Subst.module_path subst p2) in
-      (* Should actually be Tcoerce_ignore, if it existed *)
-      if Path.same p1 p2 then Tcoerce_none else raise Dont_match
-  | (Mty_alias p1, _) ->
+      if not (Path.same p1 p2) then begin
+        let p1 = Env.normalize_path None env p1
+        and p2 = Env.normalize_path None env (Subst.module_path subst p2) in
+        if not (Path.same p1 p2) then raise Dont_match
+      end;
+      match pres1, pres2 with
+      | Mta_present, Mta_present -> Tcoerce_none
+        (* Should really be Tcoerce_ignore if it existed *)
+      | Mta_absent, Mta_absent -> Tcoerce_none
+        (* Should really be Tcoerce_empty if it existed *)
+      | Mta_present, Mta_absent -> Tcoerce_none
+      | Mta_absent, Mta_present ->
+        let p1 = try
+            Env.normalize_path (Some Location.none) env p1
+          with Env.Error (Env.Missing_module (_, _, path)) ->
+            raise (Error[cxt, env, Unbound_module_path path])
+        in
+        Tcoerce_alias (p1, Tcoerce_none)
+    end
+  | (Mty_alias(pres1, p1), _) -> begin
       let p1 = try
         Env.normalize_path (Some Location.none) env p1
       with Env.Error (Env.Missing_module (_, _, path)) ->
         raise (Error[cxt, env, Unbound_module_path path])
       in
-      let mty1 = Mtype.strengthen env (expand_module_alias env cxt p1) p1 in
-      Tcoerce_alias (p1, modtypes env cxt subst mty1 mty2)
+      let mty1 =
+        Mtype.strengthen ~aliasable:true env
+          (expand_module_alias env cxt p1) p1
+      in
+      let cc = modtypes env cxt subst mty1 mty2 in
+      match pres1 with
+      | Mta_present -> cc
+      | Mta_absent -> Tcoerce_alias (p1, cc)
+    end
   | (Mty_ident p1, _) when may_expand_module_path env p1 ->
       try_modtypes env cxt subst (expand_module_path env cxt p1) mty2
-  | (_, Mty_ident p2) ->
+  | (_, Mty_ident _) ->
       try_modtypes2 env cxt mty1 (Subst.modtype subst mty2)
   | (Mty_signature sig1, Mty_signature sig2) ->
       signatures env cxt subst sig1 sig2
-  | (Mty_functor(param1, None, res1), Mty_functor(param2, None, res2)) ->
+  | (Mty_functor(param1, None, res1), Mty_functor(_param2, None, res2)) ->
       begin match modtypes env (Body param1::cxt) subst res1 res2 with
         Tcoerce_none -> Tcoerce_none
       | cc -> Tcoerce_functor (Tcoerce_none, cc)
@@ -271,12 +292,14 @@ and try_modtypes env cxt subst mty1 mty2 =
 and try_modtypes2 env cxt mty1 mty2 =
   (* mty2 is an identifier *)
   match (mty1, mty2) with
-    (Mty_ident p1, Mty_ident p2) when Path.same p1 p2 ->
+    (Mty_ident p1, Mty_ident p2)
+    when Path.same (Env.normalize_path_prefix None env p1)
+                   (Env.normalize_path_prefix None env p2) ->
       Tcoerce_none
-  | (_, Mty_ident p2) ->
+  | (_, Mty_ident p2) when may_expand_module_path env p2 ->
       try_modtypes env cxt Subst.identity mty1 (expand_module_path env cxt p2)
   | (_, _) ->
-      assert false
+      raise Dont_match
 
 (* Inclusion between signatures *)
 
@@ -372,34 +395,35 @@ and signature_components old_env env cxt subst paired =
   let comps_rec rem = signature_components old_env env cxt subst rem in
   match paired with
     [] -> []
-  | (Sig_value(id1, valdecl1), Sig_value(id2, valdecl2), pos) :: rem ->
+  | (Sig_value(id1, valdecl1), Sig_value(_id2, valdecl2), pos) :: rem ->
       let cc = value_descriptions env cxt subst id1 valdecl1 valdecl2 in
       begin match valdecl2.val_kind with
-        Val_prim p -> comps_rec rem
+        Val_prim _ -> comps_rec rem
       | _ -> (pos, cc) :: comps_rec rem
       end
-  | (Sig_type(id1, tydecl1, _), Sig_type(id2, tydecl2, _), pos) :: rem ->
+  | (Sig_type(id1, tydecl1, _), Sig_type(_id2, tydecl2, _), _pos) :: rem ->
       type_declarations ~old_env env cxt subst id1 tydecl1 tydecl2;
       comps_rec rem
-  | (Sig_typext(id1, ext1, _), Sig_typext(id2, ext2, _), pos)
+  | (Sig_typext(id1, ext1, _), Sig_typext(_id2, ext2, _), pos)
     :: rem ->
       extension_constructors env cxt subst id1 ext1 ext2;
       (pos, Tcoerce_none) :: comps_rec rem
-  | (Sig_module(id1, mty1, _), Sig_module(id2, mty2, _), pos) :: rem ->
+  | (Sig_module(id1, mty1, _), Sig_module(_id2, mty2, _), pos) :: rem ->
       let p1 = Pident id1 in
+      Env.mark_module_used env (Ident.name id1) mty1.md_loc;
       let cc =
         modtypes env (Module id1::cxt) subst
-          (Mtype.strengthen (Env.add_functor_arg id1 env) mty1.md_type p1)
-          mty2.md_type in
+          (Mtype.strengthen ~aliasable:true env mty1.md_type p1) mty2.md_type
+      in
       (pos, cc) :: comps_rec rem
-  | (Sig_modtype(id1, info1), Sig_modtype(id2, info2), pos) :: rem ->
+  | (Sig_modtype(id1, info1), Sig_modtype(_id2, info2), _pos) :: rem ->
       modtype_infos env cxt subst id1 info1 info2;
       comps_rec rem
-  | (Sig_class(id1, decl1, _), Sig_class(id2, decl2, _), pos) :: rem ->
+  | (Sig_class(id1, decl1, _), Sig_class(_id2, decl2, _), pos) :: rem ->
       class_declarations ~old_env env cxt subst id1 decl1 decl2;
       (pos, Tcoerce_none) :: comps_rec rem
   | (Sig_class_type(id1, info1, _),
-     Sig_class_type(id2, info2, _), pos) :: rem ->
+     Sig_class_type(_id2, info2, _), _pos) :: rem ->
       class_type_declarations ~old_env env cxt subst id1 info1 info2;
       comps_rec rem
   | _ ->
@@ -413,7 +437,7 @@ and modtype_infos env cxt subst id info1 info2 =
   try
     match (info1.mtd_type, info2.mtd_type) with
       (None, None) -> ()
-    | (Some mty1, None) -> ()
+    | (Some _, None) -> ()
     | (Some mty1, Some mty2) ->
         check_modtype_equiv env cxt' mty1 mty2
     | (None, Some mty2) ->
@@ -427,18 +451,27 @@ and check_modtype_equiv env cxt mty1 mty2 =
      modtypes env cxt Subst.identity mty2 mty1)
   with
     (Tcoerce_none, Tcoerce_none) -> ()
-  | (c1, c2) ->
+  | (_c1, _c2) ->
       (* Format.eprintf "@[c1 = %a@ c2 = %a@]@."
-        print_coercion c1 print_coercion c2; *)
+        print_coercion _c1 print_coercion _c2; *)
       raise(Error [cxt, env, Modtype_permutation])
 
 (* Simplified inclusion check between module types (for Env) *)
 
+let can_alias env path =
+  let rec no_apply = function
+    | Pident _ -> true
+    | Pdot(p, _, _) -> no_apply p
+    | Papply _ -> false
+  in
+  no_apply path && not (Env.is_functor_arg path env)
+
 let check_modtype_inclusion env mty1 path1 mty2 =
   try
+    let aliasable = can_alias env path1 in
     ignore(modtypes env [] Subst.identity
-                    (Mtype.strengthen env mty1 path1) mty2)
-  with Error reasons ->
+                    (Mtype.strengthen ~aliasable env mty1 path1) mty2)
+  with Error _ ->
     raise Not_found
 
 let _ = Env.check_modtype_inclusion := check_modtype_inclusion
diff --git a/typing/mtype.ml b/typing/mtype.ml
index c1995dc3..063cc366 100644
--- a/typing/mtype.ml
+++ b/typing/mtype.ml
@@ -33,26 +33,31 @@ let rec scrape env mty =
 let freshen mty =
   Subst.modtype Subst.identity mty
 
-let rec strengthen env mty p =
+let rec strengthen ~aliasable env mty p =
   match scrape env mty with
     Mty_signature sg ->
-      Mty_signature(strengthen_sig env sg p 0)
+      Mty_signature(strengthen_sig ~aliasable env sg p 0)
   | Mty_functor(param, arg, res)
     when !Clflags.applicative_functors && Ident.name param <> "*" ->
-      Mty_functor(param, arg, strengthen env res (Papply(p, Pident param)))
+      Mty_functor(param, arg,
+        strengthen ~aliasable:false env res (Papply(p, Pident param)))
   | mty ->
       mty
 
-and strengthen_sig env sg p pos =
+and strengthen_sig ~aliasable env sg p pos =
   match sg with
     [] -> []
-  | (Sig_value(id, desc) as sigelt) :: rem ->
-      let nextpos = match desc.val_kind with Val_prim _ -> pos | _ -> pos+1 in
-      sigelt :: strengthen_sig env rem p nextpos
-  | Sig_type(id, {type_kind=Type_abstract}, rs) ::
+  | (Sig_value(_, desc) as sigelt) :: rem ->
+      let nextpos =
+        match desc.val_kind with
+        | Val_prim _ -> pos
+        | _ -> pos + 1
+      in
+      sigelt :: strengthen_sig ~aliasable env rem p nextpos
+  | Sig_type(id, {type_kind=Type_abstract}, _) ::
     (Sig_type(id', {type_private=Private}, _) :: _ as rem)
     when Ident.name id = Ident.name id' ^ "#row" ->
-      strengthen_sig env rem p pos
+      strengthen_sig ~aliasable env rem p pos
   | Sig_type(id, decl, rs) :: rem ->
       let newdecl =
         match decl.type_manifest, decl.type_private, decl.type_kind with
@@ -67,18 +72,16 @@ and strengthen_sig env sg p pos =
             else
               { decl with type_manifest = manif }
       in
-      Sig_type(id, newdecl, rs) :: strengthen_sig env rem p pos
-  | (Sig_typext(id, ext, es) as sigelt) :: rem ->
-      sigelt :: strengthen_sig env rem p (pos+1)
+      Sig_type(id, newdecl, rs) :: strengthen_sig ~aliasable env rem p pos
+  | (Sig_typext _ as sigelt) :: rem ->
+      sigelt :: strengthen_sig ~aliasable env rem p (pos+1)
   | Sig_module(id, md, rs) :: rem ->
       let str =
-        if Env.is_functor_arg p env then
-          strengthen_decl env md (Pdot(p, Ident.name id, pos))
-        else
-          {md with md_type = Mty_alias (Pdot(p, Ident.name id, pos))}
+        strengthen_decl ~aliasable env md (Pdot(p, Ident.name id, pos))
       in
       Sig_module(id, str, rs)
-      :: strengthen_sig (Env.add_module_declaration id md env) rem p (pos+1)
+      :: strengthen_sig ~aliasable
+        (Env.add_module_declaration ~check:false id md env) rem p (pos+1)
       (* Need to add the module in case it defines manifest module types *)
   | Sig_modtype(id, decl) :: rem ->
       let newdecl =
@@ -89,15 +92,18 @@ and strengthen_sig env sg p pos =
             decl
       in
       Sig_modtype(id, newdecl) ::
-      strengthen_sig (Env.add_modtype id decl env) rem p pos
+      strengthen_sig ~aliasable (Env.add_modtype id decl env) rem p pos
       (* Need to add the module type in case it is manifest *)
-  | (Sig_class(id, decl, rs) as sigelt) :: rem ->
-      sigelt :: strengthen_sig env rem p (pos+1)
-  | (Sig_class_type(id, decl, rs) as sigelt) :: rem ->
-      sigelt :: strengthen_sig env rem p pos
+  | (Sig_class _ as sigelt) :: rem ->
+      sigelt :: strengthen_sig ~aliasable env rem p (pos+1)
+  | (Sig_class_type _ as sigelt) :: rem ->
+      sigelt :: strengthen_sig ~aliasable env rem p pos
 
-and strengthen_decl env md p =
-  {md with md_type = strengthen env md.md_type p}
+and strengthen_decl ~aliasable env md p =
+  match md.md_type with
+  | Mty_alias _ -> md
+  | _ when aliasable -> {md with md_type = Mty_alias(Mta_present, p)}
+  | mty -> {md with md_type = strengthen ~aliasable env mty p}
 
 let () = Env.strengthen := strengthen
 
@@ -115,7 +121,7 @@ let nondep_supertype env mid mty =
         if Path.isfree mid p then
           nondep_mty env va (Env.find_modtype_expansion p env)
         else mty
-    | Mty_alias p ->
+    | Mty_alias(_, p) ->
         if Path.isfree mid p then
           nondep_mty env va (Env.find_module p env).md_type
         else mty
@@ -171,7 +177,7 @@ let nondep_supertype env mid mty =
 
 let enrich_typedecl env p decl =
   match decl.type_manifest with
-    Some ty -> decl
+    Some _ -> decl
   | None ->
       try
         let orig_decl = Env.find_type p env in
@@ -203,22 +209,23 @@ and enrich_item env p = function
 
 let rec type_paths env p mty =
   match scrape env mty with
-    Mty_ident p -> []
-  | Mty_alias p -> []
+    Mty_ident _ -> []
+  | Mty_alias _ -> []
   | Mty_signature sg -> type_paths_sig env p 0 sg
-  | Mty_functor(param, arg, res) -> []
+  | Mty_functor _ -> []
 
 and type_paths_sig env p pos sg =
   match sg with
     [] -> []
-  | Sig_value(id, decl) :: rem ->
+  | Sig_value(_id, decl) :: rem ->
       let pos' = match decl.val_kind with Val_prim _ -> pos | _ -> pos + 1 in
       type_paths_sig env p pos' rem
-  | Sig_type(id, decl, _) :: rem ->
+  | Sig_type(id, _decl, _) :: rem ->
       Pdot(p, Ident.name id, nopos) :: type_paths_sig env p pos rem
   | Sig_module(id, md, _) :: rem ->
       type_paths env (Pdot(p, Ident.name id, pos)) md.md_type @
-      type_paths_sig (Env.add_module_declaration id md env) p (pos+1) rem
+      type_paths_sig (Env.add_module_declaration ~check:false id md env)
+        p (pos+1) rem
   | Sig_modtype(id, decl) :: rem ->
       type_paths_sig (Env.add_modtype id decl env) p pos rem
   | (Sig_typext _ | Sig_class _) :: rem ->
@@ -228,25 +235,27 @@ and type_paths_sig env p pos sg =
 
 let rec no_code_needed env mty =
   match scrape env mty with
-    Mty_ident p -> false
+    Mty_ident _ -> false
   | Mty_signature sg -> no_code_needed_sig env sg
   | Mty_functor(_, _, _) -> false
-  | Mty_alias p -> true
+  | Mty_alias(Mta_absent, _) -> true
+  | Mty_alias(Mta_present, _) -> false
 
 and no_code_needed_sig env sg =
   match sg with
     [] -> true
-  | Sig_value(id, decl) :: rem ->
+  | Sig_value(_id, decl) :: rem ->
       begin match decl.val_kind with
       | Val_prim _ -> no_code_needed_sig env rem
       | _ -> false
       end
   | Sig_module(id, md, _) :: rem ->
       no_code_needed env md.md_type &&
-      no_code_needed_sig (Env.add_module_declaration id md env) rem
+      no_code_needed_sig
+        (Env.add_module_declaration ~check:false id md env) rem
   | (Sig_type _ | Sig_modtype _ | Sig_class_type _) :: rem ->
       no_code_needed_sig env rem
-  | (Sig_typext _ | Sig_class _) :: rem ->
+  | (Sig_typext _ | Sig_class _) :: _ ->
       false
 
 
@@ -294,13 +303,8 @@ let contains_type env mty =
 
 (* Remove module aliases from a signature *)
 
-module P = struct
-  type t = Path.t
-  let compare p1 p2 =
-    if Path.same p1 p2 then 0 else compare p1 p2
-end
-module PathSet = Set.Make (P)
-module PathMap = Map.Make (P)
+module PathSet = Set.Make (Path)
+module PathMap = Map.Make (Path)
 module IdentSet = Set.Make (Ident)
 
 let rec get_prefixes = function
@@ -347,7 +351,7 @@ let collect_arg_paths mty =
   and it_signature_item it si =
     type_iterators.it_signature_item it si;
     match si with
-      Sig_module (id, {md_type=Mty_alias p}, _) ->
+      Sig_module (id, {md_type=Mty_alias(_, p)}, _) ->
         bindings := Ident.add id p !bindings
     | Sig_module (id, {md_type=Mty_signature sg}, _) ->
         List.iter
diff --git a/typing/mtype.mli b/typing/mtype.mli
index 2aaafaef..3f07db4a 100644
--- a/typing/mtype.mli
+++ b/typing/mtype.mli
@@ -24,10 +24,11 @@ val scrape: Env.t -> module_type -> module_type
 val freshen: module_type -> module_type
         (* Return an alpha-equivalent copy of the given module type
            where bound identifiers are fresh. *)
-val strengthen: Env.t -> module_type -> Path.t -> module_type
+val strengthen: aliasable:bool -> Env.t -> module_type -> Path.t -> module_type
         (* Strengthen abstract type components relative to the
            given path. *)
-val strengthen_decl: Env.t -> module_declaration -> Path.t -> module_declaration
+val strengthen_decl:
+  aliasable:bool -> Env.t -> module_declaration -> Path.t -> module_declaration
 val nondep_supertype: Env.t -> Ident.t -> module_type -> module_type
         (* Return the smallest supertype of the given type
            in which the given ident does not appear.
diff --git a/typing/oprint.ml b/typing/oprint.ml
index 5860c602..02f236cc 100644
--- a/typing/oprint.ml
+++ b/typing/oprint.ml
@@ -431,7 +431,7 @@ and print_out_sig_item ppf =
   | Osig_typext (ext, Oext_exception) ->
       fprintf ppf "@[<2>exception %a@]"
         print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type)
-  | Osig_typext (ext, es) ->
+  | Osig_typext (ext, _es) ->
       print_out_extension_constructor ppf ext
   | Osig_modtype (name, Omty_abstract) ->
       fprintf ppf "@[<2>module type %s@]" name
@@ -506,6 +506,9 @@ and print_out_type_decl kwd ppf td =
   let print_immediate ppf =
     if td.otype_immediate then fprintf ppf " [%@%@immediate]" else ()
   in
+  let print_unboxed ppf =
+    if td.otype_unboxed then fprintf ppf " [%@%@unboxed]" else ()
+  in
   let print_out_tkind ppf = function
   | Otyp_abstract -> ()
   | Otyp_record lbls ->
@@ -523,13 +526,19 @@ and print_out_type_decl kwd ppf td =
         print_private td.otype_private
         !out_type ty
   in
-  fprintf ppf "@[<2>@[%t%a@]%t%t@]"
+  fprintf ppf "@[<2>@[%t%a@]%t%t%t@]"
     print_name_params
     print_out_tkind ty
     print_constraints
     print_immediate
+    print_unboxed
 
 and print_out_constr ppf (name, tyl,ret_type_opt) =
+  let name =
+    match name with
+    | "::" -> "(::)"   (* #7200 *)
+    | s -> s
+  in
   match ret_type_opt with
   | None ->
       begin match tyl with
diff --git a/typing/outcometree.mli b/typing/outcometree.mli
index 7d4cb5b6..b926c920 100644
--- a/typing/outcometree.mli
+++ b/typing/outcometree.mli
@@ -106,6 +106,7 @@ and out_type_decl =
     otype_type: out_type;
     otype_private: Asttypes.private_flag;
     otype_immediate: bool;
+    otype_unboxed: bool;
     otype_cstrs: (out_type * out_type) list }
 and out_extension_constructor =
   { oext_name: string;
diff --git a/typing/parmatch.ml b/typing/parmatch.ml
index cc2a780f..1ebae6e8 100644
--- a/typing/parmatch.ml
+++ b/typing/parmatch.ml
@@ -93,9 +93,9 @@ let rec compat p q =
   | Tpat_lazy p, Tpat_lazy q -> compat p q
   | Tpat_construct (_, c1,ps1), Tpat_construct (_, c2,ps2) ->
       c1.cstr_tag = c2.cstr_tag && compats ps1 ps2
-  | Tpat_variant(l1,Some p1, r1), Tpat_variant(l2,Some p2,_) ->
+  | Tpat_variant(l1,Some p1, _r1), Tpat_variant(l2,Some p2,_) ->
       l1=l2 && compat p1 p2
-  | Tpat_variant (l1,None,r1), Tpat_variant(l2,None,_) ->
+  | Tpat_variant (l1,None, _r1), Tpat_variant(l2,None,_) ->
       l1 = l2
   | Tpat_variant (_, None, _), Tpat_variant (_,Some _, _) -> false
   | Tpat_variant (_, Some _, _), Tpat_variant (_, None, _) -> false
@@ -137,6 +137,13 @@ let get_type_path ty tenv =
 open Format
 ;;
 
+let pretty_record_elision_mark ppf = function
+  | [] -> () (* should not happen, empty record pattern *)
+  | (_, lbl, _) :: q ->
+      (* we assume that there is no label repetitions here *)
+      if Array.length lbl.lbl_all > 1 + List.length q then
+        fprintf ppf ";@ _@ "
+
 let is_cons = function
 | {cstr_name = "::"} -> true
 | _ -> false
@@ -156,15 +163,17 @@ let rec pretty_val ppf v =
         begin match cstr with
           | Tpat_unpack ->
             fprintf ppf "@[(module %a)@]" pretty_val { v with pat_extra = rem }
-          | Tpat_constraint ctyp ->
+          | Tpat_constraint _ ->
             fprintf ppf "@[(%a : _)@]" pretty_val { v with pat_extra = rem }
           | Tpat_type _ ->
             fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem }
+          | Tpat_open _ ->
+              fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem }
         end
     | [] ->
   match v.pat_desc with
   | Tpat_any -> fprintf ppf "_"
-  | Tpat_var (x,_) -> Ident.print ppf x
+  | Tpat_var (x,_) -> fprintf ppf "%s" (Ident.name x)
   | Tpat_constant c -> fprintf ppf "%s" (pretty_const c)
   | Tpat_tuple vs ->
       fprintf ppf "@[(%a)@]" (pretty_vals ",") vs
@@ -185,12 +194,13 @@ let rec pretty_val ppf v =
   | Tpat_variant (l, Some w, _) ->
       fprintf ppf "@[<2>`%s@ %a@]" l pretty_arg w
   | Tpat_record (lvs,_) ->
-      fprintf ppf "@[{%a}@]"
-        pretty_lvals
-        (List.filter
-           (function
-             | (_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *)
-             | _ -> true) lvs)
+      let filtered_lvs = List.filter
+          (function
+            | (_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *)
+            | _ -> true) lvs in
+      fprintf ppf "@[{%a%a}@]"
+        pretty_lvals filtered_lvs
+        pretty_record_elision_mark filtered_lvs
   | Tpat_array vs ->
       fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs
   | Tpat_lazy v ->
@@ -323,8 +333,8 @@ let all_record_args lbls = match lbls with
 (* Build argument list when p2 >= p1, where p1 is a simple pattern *)
 let rec simple_match_args p1 p2 = match p2.pat_desc with
 | Tpat_alias (p2,_,_) -> simple_match_args p1 p2
-| Tpat_construct(_, cstr, args) -> args
-| Tpat_variant(lab, Some arg, _) -> [arg]
+| Tpat_construct(_, _, args) -> args
+| Tpat_variant(_, Some arg, _) -> [arg]
 | Tpat_tuple(args)  -> args
 | Tpat_record(args,_) ->  extract_fields (record_arg p1) args
 | Tpat_array(args) -> args
@@ -455,7 +465,7 @@ let do_set_args erase_mutable q r = match q with
     make_pat
       (Tpat_variant (l, arg, row)) q.pat_type q.pat_env::
     rest
-| {pat_desc = Tpat_lazy omega} ->
+| {pat_desc = Tpat_lazy _omega} ->
     begin match r with
       arg::rest ->
         make_pat (Tpat_lazy arg) q.pat_type q.pat_env::rest
@@ -583,7 +593,7 @@ let close_variant env row =
   let row = Btype.row_repr row in
   let nm =
     List.fold_left
-      (fun nm (tag,f) ->
+      (fun nm (_tag,f) ->
         match Btype.row_field_repr f with
         | Reither(_, _, false, e) ->
             (* m=false means that this tag is not explicitly matched *)
@@ -609,23 +619,8 @@ let row_of_pat pat =
   not.
 *)
 
-let generalized_constructor x =
-  match x with
-    ({pat_desc = Tpat_construct(_,c,_);pat_env=env},_) ->
-      c.cstr_generalized
-  | _ -> assert false
-
-let clean_env env =
-  let rec loop =
-    function
-      | [] -> []
-      | x :: xs ->
-          if generalized_constructor x then loop xs else x :: loop xs
-  in
-  loop env
-
 let full_match closing env =  match env with
-| ({pat_desc = Tpat_construct(_,c,_);pat_type=typ},_) :: _ ->
+| ({pat_desc = Tpat_construct(_,c,_)},_) :: _ ->
     if c.cstr_consts < 0 then false (* extensions *)
     else List.length env = c.cstr_consts + c.cstr_nonconsts
 | ({pat_desc = Tpat_variant _} as p,_) :: _ ->
@@ -718,7 +713,7 @@ let pats_of_type ?(always=false) env ty =
         List.for_all (fun cd -> cd.Types.cd_res <> None) cl ->
           let cstrs = fst (Env.find_type_descrs path env) in
           List.map (pat_of_constr (make_pat Tpat_any ty env)) cstrs
-      | Type_record (ldl, _) ->
+      | Type_record _ ->
           let labels = snd (Env.find_type_descrs path env) in
           let fields =
             List.map (fun ld ->
@@ -748,14 +743,6 @@ let rec get_variant_constructors env ty =
     end
   | _ -> fatal_error "Parmatch.get_variant_constructors"
 
-let rec map_filter f  =
-  function
-      [] -> []
-    | x :: xs ->
-        match f x with
-        | None -> map_filter f xs
-        | Some y -> y :: map_filter f xs
-
 (* Sends back a pattern that complements constructor tags all_tag *)
 let complete_constrs p all_tags =
   let c =
@@ -794,11 +781,11 @@ let build_other_constant proj make first next p env =
 *)
 
 let build_other ext env = match env with
-| ({pat_desc = Tpat_construct (lid,
-      ({cstr_tag=Cstr_extension _} as c),_)},_) :: _ ->
-    let c = {c with cstr_name = "*extension*"} in
-      make_pat (Tpat_construct(lid, c, [])) Ctype.none Env.empty
-| ({pat_desc = Tpat_construct (_, cd,_)} as p,_) :: _ ->
+| ({pat_desc = Tpat_construct (lid, {cstr_tag=Cstr_extension _},_)},_) :: _ ->
+        (* let c = {c with cstr_name = "*extension*"} in *) (* PR#7330 *)
+        make_pat (Tpat_var (Ident.create "*extension*",
+                            {lid with txt="*extension*"})) Ctype.none Env.empty
+| ({pat_desc = Tpat_construct _} as p,_) :: _ ->
     begin match ext with
     | Some ext when Path.same ext (get_type_path p.pat_type p.pat_env) ->
         extra_pat
@@ -896,7 +883,7 @@ let build_other ext env = match env with
       (function f -> Tpat_constant(Const_float (string_of_float f)))
       0.0 (fun f -> f +. 1.0) p env
 
-| ({pat_desc = Tpat_array args} as p,_)::_ ->
+| ({pat_desc = Tpat_array _} as p,_)::_ ->
     let all_lengths =
       List.map
         (fun (p,_) -> match p.pat_desc with
@@ -1020,12 +1007,14 @@ type 'a result =
   | Rnone           (* No matching value *)
   | Rsome of 'a     (* This matching value *)
 
+(*
 let rec try_many  f = function
   | [] -> Rnone
   | (p,pss)::rest ->
       match f (p,pss) with
       | Rnone -> try_many  f rest
       | r -> r
+*)
 
 let rappend r1 r2 =
   match r1, r2 with
@@ -1214,7 +1203,7 @@ let rec pressure_variants tdefs = function
         [] -> pressure_variants tdefs (filter_extra pss)
       | constrs ->
           let rec try_non_omega = function
-              (p,pss) :: rem ->
+              (_p,pss) :: rem ->
                 let ok = pressure_variants tdefs pss in
                 try_non_omega rem && ok
             | [] -> true
@@ -1500,7 +1489,7 @@ let rec le_pat p q =
       c1.cstr_tag = c2.cstr_tag && le_pats ps qs
   | Tpat_variant(l1,Some p1,_), Tpat_variant(l2,Some p2,_) ->
       (l1 = l2 && le_pat p1 p2)
-  | Tpat_variant(l1,None,r1), Tpat_variant(l2,None,_) ->
+  | Tpat_variant(l1,None,_r1), Tpat_variant(l2,None,_) ->
       l1 = l2
   | Tpat_variant(_,_,_), Tpat_variant(_,_,_) -> false
   | Tpat_tuple(ps), Tpat_tuple(qs) -> le_pats ps qs
@@ -1555,7 +1544,7 @@ let rec lub p q = match p.pat_desc,q.pat_desc with
           when  l1=l2 ->
             let r=lub p1 p2 in
             make_pat (Tpat_variant (l1,Some r,row)) p.pat_type p.pat_env
-| Tpat_variant (l1,None,row), Tpat_variant(l2,None,_)
+| Tpat_variant (l1,None,_row), Tpat_variant(l2,None,_)
               when l1 = l2 -> p
 | Tpat_record (l1,closed),Tpat_record (l2,_) ->
     let rs = record_lubs l1 l2 in
@@ -1708,6 +1697,8 @@ module Conv = struct
       match pat.pat_desc with
         Tpat_or (pa,pb,_) ->
           mkpat (Ppat_or (loop pa, loop pb))
+      | Tpat_var (_, ({txt="*extension*"} as nm)) -> (* PR#7330 *)
+          mkpat (Ppat_var nm)
       | Tpat_any
       | Tpat_var _ ->
           mkpat Ppat_any
@@ -1727,7 +1718,7 @@ module Conv = struct
             | lst -> Some (mkpat (Ppat_tuple lst))
           in
           mkpat (Ppat_construct(lid, arg))
-      | Tpat_variant(label,p_opt,row_desc) ->
+      | Tpat_variant(label,p_opt,_row_desc) ->
           let arg = Misc.may_map loop p_opt in
           mkpat (Ppat_variant(label, arg))
       | Tpat_record (subpatterns, _closed_flag) ->
@@ -1754,7 +1745,7 @@ end
 let contains_extension pat =
   let r = ref false in
   let rec loop = function
-      {pat_desc=Tpat_construct(_, {cstr_name="*extension*"}, _)} ->
+      {pat_desc=Tpat_var (_, {txt="*extension*"})} ->
         r := true
     | p -> Typedtree.iter_pattern_desc loop p.pat_desc
   in loop pat; !r
@@ -1789,9 +1780,14 @@ let do_check_partial ?pred exhaust loc casel pss = match pss with
         let v =
           match pred with
           | Some pred ->
-              if false then Some u else
               let (pattern,constrs,labels) = Conv.conv u in
-              pred constrs labels pattern
+              let u' = pred constrs labels pattern in
+              (* pretty_pat u;
+              begin match u' with
+                None -> prerr_endline ": impossible"
+              | Some _ -> prerr_endline ": possible"
+              end; *)
+              u'
           | None -> Some u
         in
         begin match v with
@@ -1859,7 +1855,8 @@ let extendable_path path =
     Path.same path Predef.path_option)
 
 let rec collect_paths_from_pat r p = match p.pat_desc with
-| Tpat_construct(_, {cstr_tag=(Cstr_constant _|Cstr_block _)},ps) ->
+| Tpat_construct(_, {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)},ps)
+  ->
     let path =  get_type_path p.pat_type p.pat_env in
     List.fold_left
       collect_paths_from_pat
@@ -1915,7 +1912,7 @@ let do_check_fragile_gadt = do_check_fragile_param exhaust_gadt
 (* Exported unused clause check *)
 (********************************)
 
-let check_unused pred tdefs casel =
+let check_unused pred casel =
   if Warnings.is_active Warnings.Unused_match
   || List.exists (fun c -> c.c_rhs.exp_desc = Texp_unreachable) casel then
     let rec do_rec pref = function
diff --git a/typing/parmatch.mli b/typing/parmatch.mli
index e2122a68..3dcb6dde 100644
--- a/typing/parmatch.mli
+++ b/typing/parmatch.mli
@@ -71,7 +71,7 @@ val check_unused:
      (string, constructor_description) Hashtbl.t ->
      (string, label_description) Hashtbl.t ->
      Parsetree.pattern -> pattern option) ->
-    Env.t -> case list -> unit
+    case list -> unit
 
 (* Irrefutability tests *)
 val irrefutable : pattern -> bool
diff --git a/typing/path.ml b/typing/path.ml
index 035f1222..a1a81015 100644
--- a/typing/path.ml
+++ b/typing/path.ml
@@ -23,33 +23,45 @@ let nopos = -1
 let rec same p1 p2 =
   match (p1, p2) with
     (Pident id1, Pident id2) -> Ident.same id1 id2
-  | (Pdot(p1, s1, pos1), Pdot(p2, s2, pos2)) -> s1 = s2 && same p1 p2
+  | (Pdot(p1, s1, _pos1), Pdot(p2, s2, _pos2)) -> s1 = s2 && same p1 p2
   | (Papply(fun1, arg1), Papply(fun2, arg2)) ->
        same fun1 fun2 && same arg1 arg2
   | (_, _) -> false
 
+let rec compare p1 p2 =
+  match (p1, p2) with
+    (Pident id1, Pident id2) -> Ident.compare id1 id2
+  | (Pdot(p1, s1, _pos1), Pdot(p2, s2, _pos2)) ->
+      let h = compare p1 p2 in
+      if h <> 0 then h else String.compare s1 s2
+  | (Papply(fun1, arg1), Papply(fun2, arg2)) ->
+      let h = compare fun1 fun2 in
+      if h <> 0 then h else compare arg1 arg2
+  | ((Pident _ | Pdot _), (Pdot _ | Papply _)) -> -1
+  | ((Pdot _ | Papply _), (Pident _ | Pdot _)) -> 1
+
 let rec isfree id = function
     Pident id' -> Ident.same id id'
-  | Pdot(p, s, pos) -> isfree id p
+  | Pdot(p, _s, _pos) -> isfree id p
   | Papply(p1, p2) -> isfree id p1 || isfree id p2
 
 let rec binding_time = function
     Pident id -> Ident.binding_time id
-  | Pdot(p, s, pos) -> binding_time p
+  | Pdot(p, _s, _pos) -> binding_time p
   | Papply(p1, p2) -> max (binding_time p1) (binding_time p2)
 
-let kfalse x = false
+let kfalse _ = false
 
 let rec name ?(paren=kfalse) = function
     Pident id -> Ident.name id
-  | Pdot(p, s, pos) ->
+  | Pdot(p, s, _pos) ->
       name ~paren p ^ if paren s then ".( " ^ s ^ " )" else "." ^ s
   | Papply(p1, p2) -> name ~paren p1 ^ "(" ^ name ~paren p2 ^ ")"
 
 let rec head = function
     Pident id -> id
-  | Pdot(p, s, pos) -> head p
-  | Papply(p1, p2) -> assert false
+  | Pdot(p, _s, _pos) -> head p
+  | Papply _ -> assert false
 
 let heads p =
   let rec heads p acc = match p with
diff --git a/typing/path.mli b/typing/path.mli
index 7dac627c..4853f925 100644
--- a/typing/path.mli
+++ b/typing/path.mli
@@ -21,6 +21,7 @@ type t =
   | Papply of t * t
 
 val same: t -> t -> bool
+val compare: t -> t -> int
 val isfree: Ident.t -> t -> bool
 val binding_time: t -> int
 
diff --git a/typing/predef.ml b/typing/predef.ml
index db3d714c..a16997f9 100644
--- a/typing/predef.ml
+++ b/typing/predef.ml
@@ -125,6 +125,7 @@ let decl_abstr =
    type_newtype_level = None;
    type_attributes = [];
    type_immediate = false;
+   type_unboxed = unboxed_false_default_false;
   }
 
 let decl_abstr_imm = {decl_abstr with type_immediate = true}
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index abd9cb80..e5dc6157 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -53,9 +53,9 @@ let ident_pervasive = Ident.create_persistent "Pervasives"
 let rec tree_of_path = function
   | Pident id ->
       Oide_ident (ident_name id)
-  | Pdot(Pident id, s, pos) when Ident.same id ident_pervasive ->
+  | Pdot(Pident id, s, _pos) when Ident.same id ident_pervasive ->
       Oide_ident s
-  | Pdot(p, s, pos) ->
+  | Pdot(p, s, _pos) ->
       Oide_dot (tree_of_path p, s)
   | Papply(p1, p2) ->
       Oide_apply (tree_of_path p1, tree_of_path p2)
@@ -63,9 +63,9 @@ let rec tree_of_path = function
 let rec path ppf = function
   | Pident id ->
       ident ppf id
-  | Pdot(Pident id, s, pos) when Ident.same id ident_pervasive ->
+  | Pdot(Pident id, s, _pos) when Ident.same id ident_pervasive ->
       pp_print_string ppf s
-  | Pdot(p, s, pos) ->
+  | Pdot(p, s, _pos) ->
       path ppf p;
       pp_print_char ppf '.';
       pp_print_string ppf s
@@ -96,11 +96,22 @@ let raw_list pr ppf = function
       fprintf ppf "@[<1>[%a%t]@]" pr a
         (fun ppf -> List.iter (fun x -> fprintf ppf ";@,%a" pr x) l)
 
+let kind_vars = ref []
+let kind_count = ref 0
+
 let rec safe_kind_repr v = function
     Fvar {contents=Some k}  ->
       if List.memq k v then "Fvar loop" else
       safe_kind_repr (k::v) k
-  | Fvar _ -> "Fvar None"
+  | Fvar r ->
+      let vid =
+        try List.assq r !kind_vars
+        with Not_found ->
+          let c = incr kind_count; !kind_count in
+          kind_vars := (r,c) :: !kind_vars;
+          c
+      in
+      Printf.sprintf "Fvar {None}@%d" vid
   | Fpresent -> "Fpresent"
   | Fabsent -> "Fabsent"
 
@@ -118,7 +129,7 @@ let rec safe_repr v = function
 
 let rec list_of_memo = function
     Mnil -> []
-  | Mcons (priv, p, t1, t2, rem) -> p :: list_of_memo rem
+  | Mcons (_priv, p, _t1, _t2, rem) -> p :: list_of_memo rem
   | Mlink rem -> list_of_memo !rem
 
 let print_name ppf = function
@@ -200,9 +211,9 @@ and raw_field ppf = function
   | Rabsent -> fprintf ppf "Rabsent"
 
 let raw_type_expr ppf t =
-  visited := [];
+  visited := []; kind_vars := []; kind_count := 0;
   raw_type ppf t;
-  visited := []
+  visited := []; kind_vars := []
 
 let () = Btype.print_raw := raw_type_expr
 
@@ -232,20 +243,7 @@ let printing_depth = ref 0
 let printing_cont = ref ([] : Env.iter_cont list)
 let printing_old = ref Env.empty
 let printing_pers = ref Concr.empty
-module Path2 = struct
-  include Path
-  let rec compare p1 p2 =
-    (* must ignore position when comparing paths *)
-    match (p1, p2) with
-      (Pdot(p1, s1, pos1), Pdot(p2, s2, pos2)) ->
-        let c = compare p1 p2 in
-        if c <> 0 then c else String.compare s1 s2
-    | (Papply(fun1, arg1), Papply(fun2, arg2)) ->
-        let c = compare fun1 fun2 in
-        if c <> 0 then c else compare arg1 arg2
-    | _ -> Pervasives.compare p1 p2
-end
-module PathMap = Map.Make(Path2)
+module PathMap = Map.Make(Path)
 let printing_map = ref PathMap.empty
 
 let same_type t t' = repr t == repr t'
@@ -278,7 +276,8 @@ let rec normalize_type_path ?(cache=false) env p =
     | ty ->
         (p, Nth (index params ty))
   with
-    Not_found -> (p, Id)
+    Not_found ->
+      (Env.normalize_path None env p, Id)
 
 let penalty s =
   if s <> "" && s.[0] = '_' then
@@ -317,7 +316,7 @@ let set_printing_env env =
     (* printf "Recompute printing_map.@."; *)
     let cont =
       Env.iter_types
-        (fun p (p', decl) ->
+        (fun p (p', _decl) ->
           let (p1, s1) = normalize_type_path env p' ~cache:true in
           (* Format.eprintf "%a -> %a = %a@." path p path p' path p1 *)
           if s1 = Id then
@@ -336,6 +335,9 @@ let wrap_printing_env env f =
   set_printing_env env;
   try_finally f (fun () -> set_printing_env Env.empty)
 
+let wrap_printing_env env f =
+  Env.without_cmis (wrap_printing_env env) f
+
 let is_unambiguous path env =
   let l = Env.find_shadowed_types path env in
   List.exists (Path.same path) l || (* concrete paths are ok *)
@@ -349,7 +351,7 @@ let is_unambiguous path env =
       (* also allow repeatedly defining and opening (for toplevel) *)
       let id = lid_of_path p in
       List.for_all (fun p -> lid_of_path p = id) rem &&
-      Path.same p (fst (Env.lookup_type id env))
+      Path.same p (Env.lookup_type id env)
 
 let rec get_best_path r =
   match !r with
@@ -483,7 +485,7 @@ let rec mark_loops_rec visited ty =
         mark_loops_rec visited ty1; mark_loops_rec visited ty2
     | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl
     | Tconstr(p, tyl, _) ->
-        let (p', s) = best_type_path p in
+        let (_p', s) = best_type_path p in
         List.iter (mark_loops_rec visited) (apply_subst s tyl)
     | Tpackage (_, _, tyl) ->
         List.iter (mark_loops_rec visited) tyl
@@ -494,7 +496,7 @@ let rec mark_loops_rec visited ty =
           if not (static_row row) then
             visited_objects := px :: !visited_objects;
           match row.row_name with
-          | Some(p, tyl) when namable_row row ->
+          | Some(_p, tyl) when namable_row row ->
               List.iter (mark_loops_rec visited) tyl
           | _ ->
               iter_row (mark_loops_rec visited) row
@@ -575,7 +577,7 @@ let rec tree_of_typexp sch ty =
         pr_arrow l ty1 ty2
     | Ttuple tyl ->
         Otyp_tuple (tree_of_typlist sch tyl)
-    | Tconstr(p, tyl, abbrev) ->
+    | Tconstr(p, tyl, _abbrev) ->
         let p', s = best_type_path p in
         let tyl' = apply_subst s tyl in
         if is_nth s then tree_of_typexp sch (List.hd tyl') else
@@ -687,7 +689,8 @@ and tree_of_typobject sch fi nm =
                | _ -> l)
             fields [] in
         let sorted_fields =
-          List.sort (fun (n, _) (n', _) -> compare n n') present_fields in
+          List.sort
+            (fun (n, _) (n', _) -> String.compare n n') present_fields in
         tree_of_typfields sch rest sorted_fields in
       let (fields, rest) = pr_fields fi in
       Otyp_object (fields, rest)
@@ -719,19 +722,19 @@ and tree_of_typfields sch rest = function
       let (fields, rest) = tree_of_typfields sch rest l in
       (field :: fields, rest)
 
-let typexp sch prio ppf ty =
+let typexp sch ppf ty =
   !Oprint.out_type ppf (tree_of_typexp sch ty)
 
-let type_expr ppf ty = typexp false 0 ppf ty
+let type_expr ppf ty = typexp false ppf ty
 
-and type_sch ppf ty = typexp true 0 ppf ty
+and type_sch ppf ty = typexp true ppf ty
 
-and type_scheme ppf ty = reset_and_mark_loops ty; typexp true 0 ppf ty
+and type_scheme ppf ty = reset_and_mark_loops ty; typexp true ppf ty
 
 (* Maxence *)
 let type_scheme_max ?(b_reset_names=true) ppf ty =
   if b_reset_names then reset_names () ;
-  typexp true 0 ppf ty
+  typexp true ppf ty
 (* End Maxence *)
 
 let tree_of_type_scheme ty = reset_and_mark_loops ty; tree_of_typexp true ty
@@ -808,7 +811,7 @@ let rec tree_of_type_decl id decl =
            mark_loops_constructor_arguments c.cd_args;
            may mark_loops c.cd_res)
         cstrs
-  | Type_record(l, rep) ->
+  | Type_record(l, _rep) ->
       List.iter (fun l -> mark_loops l.ld_type) l
   | Type_open -> ()
   end;
@@ -860,7 +863,7 @@ let rec tree_of_type_decl id decl =
     | Type_variant cstrs ->
         tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs)),
         decl.type_private
-    | Type_record(lbls, rep) ->
+    | Type_record(lbls, _rep) ->
         tree_of_manifest (Otyp_record (List.map tree_of_label lbls)),
         decl.type_private
     | Type_open ->
@@ -868,13 +871,14 @@ let rec tree_of_type_decl id decl =
         Public
   in
   let immediate =
-    List.exists (fun (loc, _) -> loc.txt = "immediate") decl.type_attributes
+    Builtin_attributes.immediate decl.type_attributes
   in
     { otype_name = name;
       otype_params = args;
       otype_type = ty;
       otype_private = priv;
       otype_immediate = immediate;
+      otype_unboxed = decl.type_unboxed.unboxed;
       otype_cstrs = constraints }
 
 and tree_of_constructor_arguments = function
@@ -999,7 +1003,7 @@ let tree_of_metho sch concrete csil (lab, kind, ty) =
   else csil
 
 let rec prepare_class_type params = function
-  | Cty_constr (p, tyl, cty) ->
+  | Cty_constr (_p, tyl, cty) ->
       let sty = Ctype.self_type cty in
       if List.memq (proxy sty) !visited_objects
       || not (List.for_all is_Tvar params)
@@ -1130,7 +1134,7 @@ let tree_of_cltype_declaration id cl rs =
     let (fields, _) =
       Ctype.flatten_fields (Ctype.object_fields sign.csig_self) in
     List.exists
-      (fun (lab, _, ty) ->
+      (fun (lab, _, _) ->
          not (lab = dummy_method || Concr.mem lab sign.csig_concr))
       fields
     || Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) sign.csig_vars false
@@ -1169,10 +1173,11 @@ let dummy =
     type_newtype_level = None; type_loc = Location.none;
     type_attributes = [];
     type_immediate = false;
+    type_unboxed = unboxed_false_default_false;
   }
 
 let hide_rec_items = function
-  | Sig_type(id, decl, rs) ::rem
+  | Sig_type(id, _decl, rs) ::rem
     when rs = Trec_first && not !Clflags.real_paths ->
       let rec get_ids = function
           Sig_type (id, _, Trec_next) :: rem ->
@@ -1201,7 +1206,7 @@ let rec tree_of_modtype ?(ellipsis=false) = function
       in
       Omty_functor (Ident.name param,
                     may_map (tree_of_modtype ~ellipsis:false) ty_arg, res)
-  | Mty_alias p ->
+  | Mty_alias(_, p) ->
       Omty_alias (tree_of_path p)
 
 and tree_of_signature sg =
@@ -1264,7 +1269,7 @@ let modtype_declaration id ppf decl =
 let rec print_items showval env = function
   | [] -> []
   | item :: rem as items ->
-      let (sg, rem) = filter_rem_sig item rem in
+      let (_sg, rem) = filter_rem_sig item rem in
       hide_rec_items items;
       let trees = trees_of_sigitem item in
       List.map (fun d -> (d, showval env item)) trees @
@@ -1362,7 +1367,7 @@ let print_tags ppf fields =
       fprintf ppf "`%s" t;
       List.iter (fun (t, _) -> fprintf ppf ",@ `%s" t) fields
 
-let has_explanation unif t3 t4 =
+let has_explanation t3 t4 =
   match t3.desc, t4.desc with
     Tfield _, (Tnil|Tconstr _) | (Tnil|Tconstr _), Tfield _
   | Tnil, Tconstr _ | Tconstr _, Tnil
@@ -1371,12 +1376,12 @@ let has_explanation unif t3 t4 =
   | Tfield (l,_,_,{desc=Tnil}), Tfield (l',_,_,{desc=Tnil}) -> l = l'
   | _ -> false
 
-let rec mismatch unif = function
+let rec mismatch = function
     (_, t) :: (_, t') :: rem ->
-      begin match mismatch unif rem with
+      begin match mismatch rem with
         Some _ as m -> m
       | None ->
-          if has_explanation unif t t' then Some(t,t') else None
+          if has_explanation t t' then Some(t,t') else None
       end
   | [] -> None
   | _ -> assert false
@@ -1385,12 +1390,12 @@ let explanation unif t3 t4 ppf =
   match t3.desc, t4.desc with
   | Ttuple [], Tvar _ | Tvar _, Ttuple [] ->
       fprintf ppf "@,Self type cannot escape its class"
-  | Tconstr (p, tl, _), Tvar _
+  | Tconstr (p, _, _), Tvar _
     when unif && t4.level < Path.binding_time p ->
       fprintf ppf
         "@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
         path p
-  | Tvar _, Tconstr (p, tl, _)
+  | Tvar _, Tconstr (p, _, _)
     when unif && t3.level < Path.binding_time p ->
       fprintf ppf
         "@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
@@ -1492,7 +1497,7 @@ 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
-  let mis = mismatch unif tr in
+  let mis = mismatch tr in
   match tr with
   | [] | _ :: [] -> assert false
   | t1 :: t2 :: tr ->
@@ -1547,7 +1552,7 @@ let report_subtyping_error ppf env tr1 txt1 tr2 =
     and tr2 = List.map prepare_expansion tr2 in
     fprintf ppf "@[%a" (trace true (tr2 = []) txt1) tr1;
     if tr2 = [] then fprintf ppf "@]" else
-    let mis = mismatch true tr2 in
+    let mis = mismatch tr2 in
     fprintf ppf "%a%t@]"
       (trace false (mis = None) "is not compatible with type") tr2
       (explanation true mis))
diff --git a/typing/printtyped.ml b/typing/printtyped.ml
index a0cf6282..410cc1c9 100644
--- a/typing/printtyped.ml
+++ b/typing/printtyped.ml
@@ -121,6 +121,16 @@ let list i f ppf l =
      line i ppf "]\n";
 ;;
 
+let array i f ppf a =
+  if Array.length a = 0 then
+    line i ppf "[]\n"
+  else begin
+    line i ppf "[\n";
+    Array.iter (f (i+1) ppf) a;
+    line i ppf "]\n"
+  end
+;;
+
 let option i f ppf x =
   match x with
   | None -> line i ppf "None\n";
@@ -214,6 +224,10 @@ and pattern i ppf x =
         line i ppf "Tpat_type %a\n" fmt_path id;
         attributes i ppf attrs;
         pattern i ppf { x with pat_extra = rem }
+    | (Tpat_open (id,_,_), _, attrs)::rem ->
+        line i ppf "Tpat_open \"%a\"\n" fmt_path id;
+        attributes i ppf attrs;
+        pattern i ppf { x with pat_extra = rem }
     | [] ->
   match x.pat_desc with
   | Tpat_any -> line i ppf "Tpat_any\n";
@@ -231,7 +245,7 @@ and pattern i ppf x =
   | Tpat_variant (l, po, _) ->
       line i ppf "Tpat_variant \"%s\"\n" l;
       option i pattern ppf po;
-  | Tpat_record (l, c) ->
+  | Tpat_record (l, _c) ->
       line i ppf "Tpat_record\n";
       list i longident_x_pattern ppf l;
   | Tpat_array (l) ->
@@ -291,7 +305,7 @@ and expression i ppf x =
       line i ppf "Texp_apply\n";
       expression i ppf e;
       list i label_x_expression ppf l;
-  | Texp_match (e, l1, l2, partial) ->
+  | Texp_match (e, l1, l2, _partial) ->
       line i ppf "Texp_match\n";
       expression i ppf e;
       list i case ppf l1;
@@ -309,10 +323,10 @@ and expression i ppf x =
   | Texp_variant (l, eo) ->
       line i ppf "Texp_variant \"%s\"\n" l;
       option i expression ppf eo;
-  | Texp_record (l, eo) ->
+  | Texp_record { fields; extended_expression; _ } ->
       line i ppf "Texp_record\n";
-      list i longident_x_expression ppf l;
-      option i expression ppf eo;
+      array i record_field ppf fields;
+      option i expression ppf extended_expression;
   | Texp_field (e, li, _) ->
       line i ppf "Texp_field\n";
       expression i ppf e;
@@ -362,6 +376,10 @@ and expression i ppf x =
       line i ppf "Texp_letmodule \"%a\"\n" fmt_ident s;
       module_expr i ppf me;
       expression i ppf e;
+  | Texp_letexception (cd, e) ->
+      line i ppf "Pexp_letexception\n";
+      extension_constructor i ppf cd;
+      expression i ppf e;
   | Texp_assert (e) ->
       line i ppf "Texp_assert";
       expression i ppf e;
@@ -819,9 +837,12 @@ and string_x_expression i ppf (s, _, e) =
   line i ppf " \"%a\"\n" fmt_path s;
   expression (i+1) ppf e;
 
-and longident_x_expression i ppf (li, _, e) =
-  line i ppf "%a\n" fmt_longident li;
-  expression (i+1) ppf e;
+and record_field i ppf = function
+  | _, Overridden (li, e) ->
+      line i ppf "%a\n" fmt_longident li;
+      expression (i+1) ppf e;
+  | _, Kept _ ->
+      line i ppf ""
 
 and label_x_expression i ppf (l, e) =
   line i ppf "\n";
diff --git a/typing/stypes.ml b/typing/stypes.ml
index 8a3e1096..140b79e2 100644
--- a/typing/stypes.ml
+++ b/typing/stypes.ml
@@ -44,8 +44,8 @@ let get_location ti =
   | Ti_expr e  -> e.exp_loc
   | Ti_class c -> c.cl_loc
   | Ti_mod m   -> m.mod_loc
-  | An_call (l, k) -> l
-  | An_ident (l, s, k) -> l
+  | An_call (l, _k) -> l
+  | An_ident (l, _s, _k) -> l
 ;;
 
 let annotations = ref ([] : annotation list);;
diff --git a/typing/subst.ml b/typing/subst.ml
index 5ea5260e..85da130b 100644
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -82,7 +82,7 @@ let modtype_path s = function
       with Not_found -> p end
   | Pdot(p, n, pos) ->
       Pdot(module_path s p, n, pos)
-  | Papply(p1, p2) ->
+  | Papply _ ->
       fatal_error "Subst.modtype_path"
 
 let type_path s = function
@@ -90,7 +90,7 @@ let type_path s = function
       begin try Tbl.find id s.types with Not_found -> p end
   | Pdot(p, n, pos) ->
       Pdot(module_path s p, n, pos)
-  | Papply(p1, p2) ->
+  | Papply _ ->
       fatal_error "Subst.type_path"
 
 let type_path s p =
@@ -135,6 +135,10 @@ let rec typexp s ty =
       end
   | Tsubst ty ->
       ty
+  | Tfield (m, k, _t1, _t2) when not s.for_saving && m = dummy_method
+      && field_kind_repr k <> Fabsent && (repr ty).level < generic_level ->
+      (* do not copy the type of self when it is not generalized *)
+      ty
 (* cannot do it, since it would omit subsitution
   | Tvariant row when not (static_row row) ->
       ty
@@ -147,7 +151,7 @@ let rec typexp s ty =
     ty.desc <- Tsubst ty';
     ty'.desc <-
       begin match desc with
-      | Tconstr(p, tl, abbrev) ->
+      | Tconstr(p, tl, _abbrev) ->
           Tconstr(type_path s p, List.map (typexp s) tl, ref Mnil)
       | Tpackage(p, n, tl) ->
           Tpackage(modtype_path s p, n, List.map (typexp s) tl)
@@ -157,10 +161,6 @@ let rec typexp s ty =
                         None -> None
                       | Some (p, tl) ->
                           Some (type_path s p, List.map (typexp s) tl)))
-      | Tfield (m, k, t1, t2)
-        when s == identity && ty.level < generic_level && m = dummy_method ->
-          (* not allowed to lower the level of the dummy method *)
-          Tfield (m, k, t1, typexp s t2)
       | Tvariant row ->
           let row = row_repr row in
           let more = repr row.row_more in
@@ -197,7 +197,7 @@ let rec typexp s ty =
               | None ->
                   Tvariant row
           end
-      | Tfield(label, kind, t1, t2) when field_kind_repr kind = Fabsent ->
+      | Tfield(_label, kind, _t1, t2) when field_kind_repr kind = Fabsent ->
           Tlink (typexp s t2)
       | _ -> copy_type_desc (typexp s) desc
       end;
@@ -261,6 +261,7 @@ let type_declaration s decl =
       type_loc = loc s decl.type_loc;
       type_attributes = attrs s decl.type_attributes;
       type_immediate = decl.type_immediate;
+      type_unboxed = decl.type_unboxed;
     }
   in
   cleanup_types ();
@@ -345,13 +346,13 @@ let extension_constructor s ext =
 
 let rec rename_bound_idents s idents = function
     [] -> (List.rev idents, s)
-  | Sig_type(id, d, _) :: sg ->
+  | Sig_type(id, _, _) :: sg ->
       let id' = Ident.rename id in
       rename_bound_idents (add_type id (Pident id') s) (id' :: idents) sg
-  | Sig_module(id, mty, _) :: sg ->
+  | Sig_module(id, _, _) :: sg ->
       let id' = Ident.rename id in
       rename_bound_idents (add_module id (Pident id') s) (id' :: idents) sg
-  | Sig_modtype(id, d) :: sg ->
+  | Sig_modtype(id, _) :: sg ->
       let id' = Ident.rename id in
       rename_bound_idents (add_modtype id (Mty_ident(Pident id')) s)
                           (id' :: idents) sg
@@ -370,7 +371,7 @@ let rec modtype s = function
           begin try Tbl.find id s.modtypes with Not_found -> mty end
       | Pdot(p, n, pos) ->
           Mty_ident(Pdot(module_path s p, n, pos))
-      | Papply(p1, p2) ->
+      | Papply _ ->
           fatal_error "Subst.modtype"
       end
   | Mty_signature sg ->
@@ -379,8 +380,8 @@ let rec modtype s = function
       let id' = Ident.rename id in
       Mty_functor(id', may_map (modtype s) arg,
                        modtype (add_module id (Pident id') s) res)
-  | Mty_alias p ->
-      Mty_alias(module_path s p)
+  | Mty_alias(pres, p) ->
+      Mty_alias(pres, module_path s p)
 
 and signature s sg =
   (* Components of signature may be mutually recursive (e.g. type declarations
@@ -392,19 +393,19 @@ and signature s sg =
 
 and signature_component s comp newid =
   match comp with
-    Sig_value(id, d) ->
+    Sig_value(_id, d) ->
       Sig_value(newid, value_description s d)
-  | Sig_type(id, d, rs) ->
+  | Sig_type(_id, d, rs) ->
       Sig_type(newid, type_declaration s d, rs)
-  | Sig_typext(id, ext, es) ->
+  | Sig_typext(_id, ext, es) ->
       Sig_typext(newid, extension_constructor s ext, es)
-  | Sig_module(id, d, rs) ->
+  | Sig_module(_id, d, rs) ->
       Sig_module(newid, module_declaration s d, rs)
-  | Sig_modtype(id, d) ->
+  | Sig_modtype(_id, d) ->
       Sig_modtype(newid, modtype_declaration s d)
-  | Sig_class(id, d, rs) ->
+  | Sig_class(_id, d, rs) ->
       Sig_class(newid, class_declaration s d, rs)
-  | Sig_class_type(id, d, rs) ->
+  | Sig_class_type(_id, d, rs) ->
       Sig_class_type(newid, cltype_declaration s d, rs)
 
 and module_declaration s decl =
diff --git a/typing/tast_mapper.ml b/typing/tast_mapper.ml
index 66127d50..e77299ce 100644
--- a/typing/tast_mapper.ml
+++ b/typing/tast_mapper.ml
@@ -186,6 +186,7 @@ let pat sub x =
   let extra = function
     | Tpat_type _
     | Tpat_unpack as d -> d
+    | Tpat_open (path,loc,env) ->  Tpat_open (path, loc, sub.env sub env)
     | Tpat_constraint ct -> Tpat_constraint (sub.typ sub ct)
   in
   let pat_env = sub.env sub x.pat_env in
@@ -254,11 +255,17 @@ let expr sub x =
         Texp_construct (lid, cd, List.map (sub.expr sub) args)
     | Texp_variant (l, expo) ->
         Texp_variant (l, opt (sub.expr sub) expo)
-    | Texp_record (list, expo) ->
-        Texp_record (
-          List.map (tuple3 id id (sub.expr sub)) list,
-          opt (sub.expr sub) expo
-        )
+    | Texp_record { fields; representation; extended_expression } ->
+        let fields = Array.map (function
+            | label, Kept t -> label, Kept t
+            | label, Overridden (lid, exp) ->
+                label, Overridden (lid, sub.expr sub exp))
+            fields
+        in
+        Texp_record {
+          fields; representation;
+          extended_expression = opt (sub.expr sub) extended_expression;
+        }
     | Texp_field (exp, lid, ld) ->
         Texp_field (sub.expr sub exp, lid, ld)
     | Texp_setfield (exp1, lid, ld, exp2) ->
@@ -323,6 +330,11 @@ let expr sub x =
           sub.module_expr sub mexpr,
           sub.expr sub exp
         )
+    | Texp_letexception (cd, exp) ->
+        Texp_letexception (
+          sub.extension_constructor sub cd,
+          sub.expr sub exp
+        )
     | Texp_assert exp ->
         Texp_assert (sub.expr sub exp)
     | Texp_lazy exp ->
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 884fdfe5..daaeab47 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -21,6 +21,32 @@ open Typecore
 open Typetexp
 open Format
 
+type 'a class_info = {
+  cls_id : Ident.t;
+  cls_id_loc : string loc;
+  cls_decl : class_declaration;
+  cls_ty_id : Ident.t;
+  cls_ty_decl : class_type_declaration;
+  cls_obj_id : Ident.t;
+  cls_obj_abbr : type_declaration;
+  cls_typesharp_id : Ident.t;
+  cls_abbr : type_declaration;
+  cls_arity : int;
+  cls_pub_methods : string list;
+  cls_info : 'a;
+}
+
+type class_type_info = {
+  clsty_ty_id : Ident.t;
+  clsty_id_loc : string loc;
+  clsty_ty_decl : class_type_declaration;
+  clsty_obj_id : Ident.t;
+  clsty_obj_abbr : type_declaration;
+  clsty_typesharp_id : Ident.t;
+  clsty_abbr : type_declaration;
+  clsty_info : Typedtree.class_type_declaration;
+}
+
 type error =
     Unconsistent_constraint of (type_expr * type_expr) list
   | Field_type_mismatch of string * string * (type_expr * type_expr) list
@@ -123,18 +149,18 @@ let rec constructor_type constr cty =
   match cty with
     Cty_constr (_, _, cty) ->
       constructor_type constr cty
-  | Cty_signature sign ->
+  | Cty_signature _ ->
       constr
   | Cty_arrow (l, ty, cty) ->
       Ctype.newty (Tarrow (l, ty, constructor_type constr cty, Cok))
 
 let rec class_body cty =
   match cty with
-    Cty_constr (_, _, cty') ->
+    Cty_constr _ ->
       cty (* Only class bodies can be abbreviated *)
-  | Cty_signature sign ->
+  | Cty_signature _ ->
       cty
-  | Cty_arrow (_, ty, cty) ->
+  | Cty_arrow (_, _, cty) ->
       class_body cty
 
 let extract_constraints cty =
@@ -182,7 +208,7 @@ let closed_class cty =
 
 let rec limited_generalize rv =
   function
-    Cty_constr (path, params, cty) ->
+    Cty_constr (_path, params, cty) ->
       List.iter (Ctype.limited_generalize rv) params;
       limited_generalize rv cty
   | Cty_signature sign ->
@@ -365,10 +391,10 @@ let make_method loc cl_num expr =
 
 (*******************************)
 
-let add_val env loc lab (mut, virt, ty) val_sig =
+let add_val lab (mut, virt, ty) val_sig =
   let virt =
     try
-      let (mut', virt', ty') = Vars.find lab val_sig in
+      let (_mut', virt', _ty') = Vars.find lab val_sig in
       if virt' = Concrete then virt' else virt
     with Not_found -> virt
   in
@@ -393,7 +419,7 @@ let rec class_type_field env self_type meths
           parent.cltyp_type
       in
       let val_sig =
-        Vars.fold (add_val env sparent.pcty_loc) cl_sig.csig_vars val_sig in
+        Vars.fold add_val cl_sig.csig_vars val_sig in
       (mkctf (Tctf_inherit parent) :: fields,
        val_sig, concr_meths, inher)
 
@@ -401,7 +427,7 @@ let rec class_type_field env self_type meths
       let cty = transl_simple_type env false sty in
       let ty = cty.ctyp_type in
       (mkctf (Tctf_val (lab, mut, virt, cty)) :: fields,
-      add_val env ctf.pctf_loc lab (mut, virt, ty) val_sig, concr_meths, inher)
+      add_val lab (mut, virt, ty) val_sig, concr_meths, inher)
 
   | Pctf_method (lab, priv, virt, sty)  ->
       let cty =
@@ -569,7 +595,7 @@ let rec class_field self_loc cl_num self_type meths vars
           None ->
             (val_env, met_env, par_env)
         | Some name ->
-            let (id, val_env, met_env, par_env) =
+            let (_id, val_env, met_env, par_env) =
               enter_met_env ~check:(fun s -> Warnings.Unused_ancestor s)
                 sparent.pcl_loc name (Val_anc (inh_meths, cl_num)) self_type
                 val_env met_env par_env
@@ -790,7 +816,7 @@ and class_structure cl_num final val_env met_env loc
   Ctype.unify val_env self_type (Ctype.newvar ());
   let sign =
     {csig_self = public_self;
-     csig_vars = Vars.map (fun (id, mut, vr, ty) -> (mut, vr, ty)) !vars;
+     csig_vars = Vars.map (fun (_id, mut, vr, ty) -> (mut, vr, ty)) !vars;
      csig_concr = concr_meths;
       csig_inher = inher} in
   let methods = get_methods self_type in
@@ -804,7 +830,7 @@ and class_structure cl_num final val_env met_env loc
     let mets = virtual_methods {sign with csig_self = self_type} in
     let vals =
       Vars.fold
-        (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l)
+        (fun name (_mut, vr, _ty) l -> if vr = Virtual then name :: l else l)
         sign.csig_vars [] in
     if mets <> [] || vals <> [] then
       raise(Error(loc, val_env, Virtual_class(true, final, mets, vals)));
@@ -838,7 +864,7 @@ and class_structure cl_num final val_env met_env loc
     Meths.iter (fun _ (_,ty) -> Ctype.unify val_env ty (Ctype.newvar ())) ms
   end;
   let fields = List.map Lazy.force (List.rev fields) in
-  let meths = Meths.map (function (id, ty) -> id) !meths in
+  let meths = Meths.map (function (id, _ty) -> id) !meths in
 
   (* Check for private methods made public *)
   let pub_meths' =
@@ -946,7 +972,7 @@ and class_expr cl_num val_env met_env scl =
       end;
       let pv =
         List.map
-          begin fun (id, id_loc, id', ty) ->
+          begin fun (id, id_loc, id', _ty) ->
             let path = Pident id' in
             (* do not mark the value as being used *)
             let vd = Env.find_value path val_env' in
@@ -1217,6 +1243,7 @@ let temp_abbrev loc env id arity =
        type_loc = loc;
        type_attributes = []; (* or keep attrs from the class decl? *)
        type_immediate = false;
+       type_unboxed = unboxed_false_default_false;
       }
       env
   in
@@ -1415,7 +1442,7 @@ let class_infos define_class kind
     let mets = virtual_methods sign in
     let vals =
       Vars.fold
-        (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l)
+        (fun name (_mut, vr, _ty) l -> if vr = Virtual then name :: l else l)
         sign.csig_vars [] in
     if mets <> []  || vals <> [] then
       raise(Error(cl.pci_loc, env, Virtual_class(define_class, false, mets,
@@ -1464,6 +1491,7 @@ let class_infos define_class kind
      type_loc = cl.pci_loc;
      type_attributes = []; (* or keep attrs from cl? *)
      type_immediate = false;
+     type_unboxed = unboxed_false_default_false;
     }
   in
   let (cl_params, cl_ty) =
@@ -1482,6 +1510,7 @@ let class_infos define_class kind
      type_loc = cl.pci_loc;
      type_attributes = []; (* or keep attrs from cl? *)
      type_immediate = false;
+     type_unboxed = unboxed_false_default_false;
     }
   in
   ((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci_params,
@@ -1532,7 +1561,7 @@ let final_decl env define_class
      ci_id_class = id;
      ci_id_class_type = ty_id;
      ci_id_object = obj_id;
-     ci_id_typesharp = cl_id;
+     ci_id_typehash = cl_id;
      ci_expr = expr;
      ci_decl = clty;
      ci_type_decl = cltydef;
@@ -1541,8 +1570,8 @@ let final_decl env define_class
 (*   (cl.pci_variance, cl.pci_loc)) *)
 
 let extract_type_decls
-    (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
-     arity, pub_meths, coe, expr, required) decls =
+    (_id, _id_loc, clty, _ty_id, cltydef, obj_id, obj_abbr, _cl_id, cl_abbr,
+     _arity, _pub_meths, _coe, _expr, required) decls =
   (obj_id, obj_abbr, cl_abbr, clty, cltydef, required) :: decls
 
 let merge_type_decls
@@ -1552,8 +1581,8 @@ let merge_type_decls
    arity, pub_meths, coe, expr, req)
 
 let final_env define_class env
-    (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
-     arity, pub_meths, coe, expr, req) =
+    (id, _id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
+     _arity, _pub_meths, _coe, _expr, _req) =
   (* Add definitions after cleaning them *)
   Env.add_type ~check:true obj_id
     (Subst.type_declaration Subst.identity obj_abbr) (
@@ -1567,7 +1596,7 @@ let final_env define_class env
 (* Check that #c is coercible to c if there is a self-coercion *)
 let check_coercions env
     (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
-     arity, pub_meths, coercion_locs, expr, req) =
+     arity, pub_meths, coercion_locs, _expr, req) =
   begin match coercion_locs with [] -> ()
   | loc :: _ ->
       let cl_ty, obj_ty =
@@ -1589,8 +1618,18 @@ let check_coercions env
       if not (Ctype.opened_object cl_ty) then
         raise(Error(loc, env, Cannot_coerce_self obj_ty))
   end;
-  (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
-   arity, pub_meths, req)
+  {cls_id = id;
+   cls_id_loc = id_loc;
+   cls_decl = clty;
+   cls_ty_id = ty_id;
+   cls_ty_decl = cltydef;
+   cls_obj_id = obj_id;
+   cls_obj_abbr = obj_abbr;
+   cls_typesharp_id = cl_id;
+   cls_abbr = cl_abbr;
+   cls_arity = arity;
+   cls_pub_methods = pub_meths;
+   cls_info=req}
 
 (*******************************)
 
@@ -1637,15 +1676,20 @@ let class_descriptions env cls =
   type_classes true approx_description class_description env cls
 
 let class_type_declarations env cls =
-  let (decl, env) =
+  let (decls, env) =
     type_classes false approx_description class_description env cls
   in
   (List.map
-     (function
-       (_, id_loc, _, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
-        _, _, ci) ->
-       (ty_id, id_loc, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci))
-     decl,
+     (fun decl ->
+        {clsty_ty_id = decl.cls_ty_id;
+         clsty_id_loc = decl.cls_id_loc;
+         clsty_ty_decl = decl.cls_ty_decl;
+         clsty_obj_id = decl.cls_obj_id;
+         clsty_obj_abbr = decl.cls_obj_abbr;
+         clsty_typesharp_id = decl.cls_typesharp_id;
+         clsty_abbr = decl.cls_abbr;
+         clsty_info = decl.cls_info})
+     decls,
    env)
 
 let rec unify_parents env ty cl =
@@ -1657,7 +1701,7 @@ let rec unify_parents env ty cl =
         Ctype.unify env ty (Ctype.instance env body)
       with
         Not_found -> ()
-      | exn -> assert false
+      | _exn -> assert false
       end
   | Tcl_structure st -> unify_parents_struct env ty st
   | Tcl_fun (_, _, _, cl, _)
@@ -1722,7 +1766,7 @@ let report_error env ppf = function
       fprintf ppf
         "@[This class expression is not a class structure; it has type@ %a@]"
         Printtyp.class_type clty
-  | Cannot_apply clty ->
+  | Cannot_apply _ ->
       fprintf ppf
         "This class expression is not a class function, it cannot be applied"
   | Apply_wrong_label l ->
@@ -1846,7 +1890,7 @@ let report_error env ppf = function
            fprintf ppf "This object is expected to have type")
         (function ppf ->
            fprintf ppf "but actually has type")
-  | Mutability_mismatch (lab, mut) ->
+  | Mutability_mismatch (_lab, mut) ->
       let mut1, mut2 =
         if mut = Immutable then "mutable", "immutable"
         else "immutable", "mutable" in
diff --git a/typing/typeclass.mli b/typing/typeclass.mli
index b6157be1..1735bf9e 100644
--- a/typing/typeclass.mli
+++ b/typing/typeclass.mli
@@ -17,13 +17,35 @@ open Asttypes
 open Types
 open Format
 
+type 'a class_info = {
+  cls_id : Ident.t;
+  cls_id_loc : string loc;
+  cls_decl : class_declaration;
+  cls_ty_id : Ident.t;
+  cls_ty_decl : class_type_declaration;
+  cls_obj_id : Ident.t;
+  cls_obj_abbr : type_declaration;
+  cls_typesharp_id : Ident.t;
+  cls_abbr : type_declaration;
+  cls_arity : int;
+  cls_pub_methods : string list;
+  cls_info : 'a;
+}
+
+type class_type_info = {
+  clsty_ty_id : Ident.t;
+  clsty_id_loc : string loc;
+  clsty_ty_decl : class_type_declaration;
+  clsty_obj_id : Ident.t;
+  clsty_obj_abbr : type_declaration;
+  clsty_typesharp_id : Ident.t;
+  clsty_abbr : type_declaration;
+  clsty_info : Typedtree.class_type_declaration;
+}
+
 val class_declarations:
   Env.t -> Parsetree.class_declaration list ->
-  (Ident.t * string loc * class_declaration *
-   Ident.t * class_type_declaration *
-   Ident.t * type_declaration *
-   Ident.t * type_declaration *
-   int * string list * Typedtree.class_declaration) list * Env.t
+  Typedtree.class_declaration class_info list * Env.t
 
 (*
 and class_declaration =
@@ -32,11 +54,7 @@ and class_declaration =
 
 val class_descriptions:
   Env.t -> Parsetree.class_description list ->
-  (Ident.t * string loc * class_declaration *
-   Ident.t * class_type_declaration *
-   Ident.t * type_declaration *
-   Ident.t * type_declaration *
-   int * string list * Typedtree.class_description) list * Env.t
+  Typedtree.class_description class_info list * Env.t
 
 (*
 and class_description =
@@ -44,11 +62,7 @@ and class_description =
 *)
 
 val class_type_declarations:
-  Env.t -> Parsetree.class_description list ->
-  (Ident.t * string loc * class_type_declaration *
-   Ident.t * type_declaration *
-   Ident.t * type_declaration *
-  Typedtree.class_type_declaration) list * Env.t
+  Env.t -> Parsetree.class_description list -> class_type_info list * Env.t
 
 (*
 and class_type_declaration =
@@ -56,11 +70,7 @@ and class_type_declaration =
 *)
 
 val approx_class_declarations:
-  Env.t -> Parsetree.class_description list ->
-  (Ident.t * string loc * class_type_declaration *
-   Ident.t * type_declaration *
-   Ident.t * type_declaration *
-  Typedtree.class_type_declaration) list
+  Env.t -> Parsetree.class_description list -> class_type_info list
 
 val virtual_methods: Types.class_signature -> label list
 
diff --git a/typing/typecore.ml b/typing/typecore.ml
index dd355320..116dc1b9 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -84,7 +84,7 @@ exception Error_forward of Location.error
 (* Forward declaration, to be filled in by Typemod.type_module *)
 
 let type_module =
-  ref ((fun env md -> assert false) :
+  ref ((fun _env _md -> assert false) :
        Env.t -> Parsetree.module_expr -> Typedtree.module_expr)
 
 (* Forward declaration, to be filled in by Typemod.type_open *)
@@ -99,7 +99,7 @@ let type_package =
 
 (* Forward declaration, to be filled in by Typeclass.class_structure *)
 let type_object =
-  ref (fun env s -> assert false :
+  ref (fun _env _s -> assert false :
        Env.t -> Location.t -> Parsetree.class_structure ->
          Typedtree.class_structure * Types.class_signature * string list)
 
@@ -162,6 +162,7 @@ let iter_expression f e =
     | Pexp_send (e, _)
     | Pexp_constraint (e, _)
     | Pexp_coerce (e, _, _)
+    | Pexp_letexception (_, e)
     | Pexp_field (e, _) -> expr e
     | Pexp_while (e1, e2)
     | Pexp_sequence (e1, e2)
@@ -332,7 +333,7 @@ let extract_concrete_variant env ty =
   | (p0, p, {type_kind=Type_open}) -> (p0, p, [])
   | _ -> raise Not_found
 
-let extract_label_names sexp env ty =
+let extract_label_names env ty =
   try
     let (_, _,fields) = extract_concrete_record env ty in
     List.map (fun l -> l.Types.ld_id) fields
@@ -410,7 +411,7 @@ let finalize_variant pat =
           begin match opat with None -> assert false
           | Some pat -> List.iter (unify_pat pat.pat_env pat) (ty::tl)
           end
-      | Reither (c, l, true, e) when not (row_fixed row) ->
+      | Reither (c, _l, true, e) when not (row_fixed row) ->
           set_row_field e (Reither (c, [], false, ref None))
       | _ -> ()
       end;
@@ -481,7 +482,8 @@ let enter_orpat_variables loc env  p1_vs p2_vs =
   let rec unify_vars p1_vs p2_vs =
     let vars vs = List.map (fun (x,_t,_,_l,_a) -> x) vs in
     match p1_vs, p2_vs with
-      | (x1,t1,_,l1,a1)::rem1, (x2,t2,_,l2,a2)::rem2 when Ident.equal x1 x2 ->
+      | (x1,t1,_,_l1,_a1)::rem1, (x2,t2,_,_l2,_a2)::rem2
+        when Ident.equal x1 x2 ->
           if x1==x2 then
             unify_vars rem1 rem2
           else begin
@@ -641,7 +643,7 @@ module NameChoice(Name : sig
 end) = struct
   open Name
 
-  let get_type_path env d =
+  let get_type_path d =
     match (repr (get_type d)).desc with
     | Tconstr(p, _, _) -> p
     | _ -> assert false
@@ -667,9 +669,9 @@ end) = struct
         else unique eq (x :: acc) rem
 
   let ambiguous_types env lbl others =
-    let tpath = get_type_path env lbl in
+    let tpath = get_type_path lbl in
     let others =
-      List.map (fun (lbl, _) -> get_type_path env lbl) others in
+      List.map (fun (lbl, _) -> get_type_path lbl) others in
     let tpaths = unique (compare_type_path env) [tpath] others in
     match tpaths with
       [_] -> []
@@ -677,7 +679,7 @@ end) = struct
 
   let disambiguate_by_type env tpath lbls =
     let check_type (lbl, _) =
-      let lbl_tpath = get_type_path env lbl in
+      let lbl_tpath = get_type_path lbl in
       compare_type_path env tpath lbl_tpath
     in
     List.find check_type lbls
@@ -712,8 +714,8 @@ end) = struct
             (* Check if non-principal type is affecting result *)
             match lbls with
               [] -> warn_pr ()
-            | (lbl', use') :: rest ->
-                let lbl_tpath = get_type_path env lbl' in
+            | (lbl', _use') :: rest ->
+                let lbl_tpath = get_type_path lbl' in
                 if not (compare_type_path env tpath lbl_tpath) then warn_pr ()
                 else
                   let paths = ambiguous_types env lbl rest in
@@ -740,7 +742,7 @@ end) = struct
           let tpl =
             List.map
               (fun (lbl, _) ->
-                let tp0 = get_type_path env lbl in
+                let tp0 = get_type_path lbl in
                 let tp = expand_path env tp0 in
                   (tp0, tp))
               lbls
@@ -771,11 +773,11 @@ module Label = NameChoice (struct
   let unbound_name_error = Typetexp.unbound_label_error
   let in_env lbl =
     match lbl.lbl_repres with
-    | Record_regular | Record_float -> true
-    | Record_inlined _ | Record_extension -> false
+    | Record_regular | Record_float | Record_unboxed false -> true
+    | Record_unboxed true | Record_inlined _ | Record_extension -> false
 end)
 
-let disambiguate_label_by_ids keep env closed ids labels =
+let disambiguate_label_by_ids keep closed ids labels =
   let check_ids (lbl, _) =
     let lbls = Hashtbl.create 8 in
     Array.iter (fun lbl -> Hashtbl.add lbls lbl.lbl_name ()) lbl.lbl_all;
@@ -819,7 +821,7 @@ let disambiguate_lid_a_list loc closed env opath lid_a_list =
     let (ok, labels) =
       match opath with
         Some (_, _, true) -> (true, scope) (* disambiguate only checks scope *)
-      | _  -> disambiguate_label_by_ids (opath=None) env closed ids scope
+      | _  -> disambiguate_label_by_ids (opath=None) closed ids scope
     in
     if ok then Label.disambiguate lid env opath labels ~warn ~scope
           else fst (List.hd labels) (* will fail later *)
@@ -831,9 +833,9 @@ let disambiguate_lid_a_list loc closed env opath lid_a_list =
       (Warnings.Not_principal "this type-based record disambiguation")
   else begin
     match List.rev !w_amb with
-      (_,types)::others as amb ->
+      (_,types)::_ as amb ->
         let paths =
-          List.map (fun (_,lbl,_) -> Label.get_type_path env lbl) lbl_a_list in
+          List.map (fun (_,lbl,_) -> Label.get_type_path lbl) lbl_a_list in
         let path = List.hd paths in
         if List.for_all (compare_type_path env path) (List.tl paths) then
           Location.prerr_warning loc
@@ -1004,8 +1006,10 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env
           ~explode sp expected_ty k
       else k' Tpat_any
   | Ppat_var name ->
-      assert (constrs = None);
-      let id = enter_variable loc name expected_ty in
+      let id = (* PR#7330 *)
+        if name.txt = "*extension*" then Ident.create name.txt else
+        enter_variable loc name expected_ty
+      in
       rp k {
         pat_desc = Tpat_var (id, name);
         pat_loc = loc; pat_extra=[];
@@ -1264,7 +1268,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env
       unify_pat_types
         loc !env (instance_def (Predef.type_array ty_elt)) expected_ty;
       let spl_ann = List.map (fun p -> (p,newvar())) spl in
-      map_fold_cont (fun (p,t) -> type_pat p ty_elt) spl_ann (fun pl ->
+      map_fold_cont (fun (p,_) -> type_pat p ty_elt) spl_ann (fun pl ->
         rp k {
         pat_desc = Tpat_array pl;
         pat_loc = loc; pat_extra=[];
@@ -1360,6 +1364,15 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env
       unify_pat_types loc !env ty expected_ty;
       k { p with pat_extra =
         (Tpat_type (path, lid), loc, sp.ppat_attributes) :: p.pat_extra }
+  | Ppat_open (lid,p) ->
+      let path, new_env =
+        !type_open Asttypes.Fresh !env sp.ppat_loc lid in
+      let new_env = ref new_env in
+      type_pat ~env:new_env p expected_ty ( fun p ->
+        env := Env.copy_local !env ~from:!new_env;
+        k { p with pat_extra =( Tpat_open (path,lid,!new_env),
+                            loc, sp.ppat_attributes) :: p.pat_extra }
+      )
   | Ppat_exception _ ->
       raise (Error (loc, !env, Exception_pattern_below_toplevel))
   | Ppat_extension ext ->
@@ -1388,8 +1401,10 @@ let partial_pred ~lev ?mode ?explode env expected_ty constrs labels p =
   try
     reset_pattern None true;
     let typed_p =
-      type_pat ~allow_existentials:true ~lev
-        ~constrs ~labels ?mode ?explode env p expected_ty
+      Ctype.with_passive_variants
+        (type_pat ~allow_existentials:true ~lev
+           ~constrs ~labels ?mode ?explode env p)
+        expected_ty
     in
     set_state state env;
     (* types are invalidated but we don't need them here *)
@@ -1413,12 +1428,12 @@ let check_unused ?(lev=get_current_level ()) env expected_ty cases =
         Some pat when refute ->
           raise (Error (spat.ppat_loc, env, Unrefuted_pattern pat))
       | r -> r)
-    env cases
+    cases
 
 let add_pattern_variables ?check ?check_as env =
   let pv = get_ref pattern_variables in
   (List.fold_right
-     (fun (id, ty, name, loc, as_var) env ->
+     (fun (id, ty, _name, loc, as_var) env ->
        let check = if as_var then check_as else check in
        Env.add_value ?check id
          {val_type = ty; val_kind = Val_reg; Types.val_loc = loc;
@@ -1490,7 +1505,7 @@ let type_self_pattern cl_num privty val_env met_env par_env spat =
   pattern_variables := [];
   let (val_env, met_env, par_env) =
     List.fold_right
-      (fun (id, ty, name, loc, as_var) (val_env, met_env, par_env) ->
+      (fun (id, ty, _name, loc, as_var) (val_env, met_env, par_env) ->
          (Env.add_value id {val_type = ty;
                             val_kind = Val_unbound;
                             val_attributes = [];
@@ -1544,7 +1559,7 @@ let rec is_nonexpansive exp =
   match exp.exp_desc with
     Texp_ident(_,_,_) -> true
   | Texp_constant _ -> true
-  | Texp_let(rec_flag, pat_exp_list, body) ->
+  | Texp_let(_rec_flag, pat_exp_list, body) ->
       List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list &&
       is_nonexpansive body
   | Texp_function _ -> true
@@ -1561,16 +1576,20 @@ let rec is_nonexpansive exp =
   | Texp_construct( _, _, el) ->
       List.for_all is_nonexpansive el
   | Texp_variant(_, arg) -> is_nonexpansive_opt arg
-  | Texp_record(lbl_exp_list, opt_init_exp) ->
-      List.for_all
-        (fun (_, lbl, exp) -> lbl.lbl_mut = Immutable && is_nonexpansive exp)
-        lbl_exp_list
-      && is_nonexpansive_opt opt_init_exp
-  | Texp_field(exp, lbl, _) -> is_nonexpansive exp
+  | Texp_record { fields; extended_expression } ->
+      Array.for_all
+        (fun (lbl, definition) ->
+           match definition with
+           | Overridden (_, exp) ->
+               lbl.lbl_mut = Immutable && is_nonexpansive exp
+           | Kept _ -> true)
+        fields
+      && is_nonexpansive_opt extended_expression
+  | Texp_field(exp, _, _) -> is_nonexpansive exp
   | Texp_array [] -> true
-  | Texp_ifthenelse(cond, ifso, ifnot) ->
+  | Texp_ifthenelse(_cond, ifso, ifnot) ->
       is_nonexpansive ifso && is_nonexpansive_opt ifnot
-  | Texp_sequence (e1, e2) -> is_nonexpansive e2  (* PR#4354 *)
+  | Texp_sequence (_e1, e2) -> is_nonexpansive e2  (* PR#4354 *)
   | Texp_new (_, _, cl_decl) when Ctype.class_type_arity cl_decl.cty_type > 0 ->
       true
   (* Note: nonexpansive only means no _observable_ side effects *)
@@ -1645,7 +1664,8 @@ let rec approx_type env sty =
       newty (Ttuple (List.map (approx_type env) args))
   | Ptyp_constr (lid, ctl) ->
       begin try
-        let (path, decl) = Env.lookup_type lid.txt env in
+        let path = Env.lookup_type lid.txt env in
+        let decl = Env.find_type path env in
         if List.length ctl <> decl.type_arity then raise Not_found;
         let tyl = List.map (approx_type env) ctl in
         newconstr path tyl
@@ -1809,8 +1829,9 @@ let iter_ppat f p =
   | Ppat_variant (_, arg) | Ppat_construct (_, arg) -> may f arg
   | Ppat_tuple lst ->  List.iter f lst
   | Ppat_exception p | Ppat_alias (p,_)
+  | Ppat_open (_,p)
   | Ppat_constraint (p,_) | Ppat_lazy p -> f p
-  | Ppat_record (args, flag) -> List.iter (fun (_,p) -> f p) args
+  | Ppat_record (args, _flag) -> List.iter (fun (_,p) -> f p) args
 
 let contains_polymorphic_variant p =
   let rec loop p =
@@ -1821,18 +1842,21 @@ let contains_polymorphic_variant p =
   try loop p; false with Exit -> true
 
 let contains_gadt env p =
-  let rec loop p =
+  let rec loop env p =
     match p.ppat_desc with
-      Ppat_construct (lid, _) ->
+      | Ppat_construct (lid, _) ->
         begin try
           let cstrs = Env.lookup_all_constructors lid.txt env in
           List.iter (fun (cstr,_) -> if cstr.cstr_generalized then raise Exit)
             cstrs
         with Not_found -> ()
-        end; iter_ppat loop p
-    | _ -> iter_ppat loop p
+        end; iter_ppat (loop env) p
+      | Ppat_open (lid,sub_p) ->
+        let _, new_env = !type_open Asttypes.Fresh env p.ppat_loc lid in
+        loop new_env sub_p
+    | _ -> iter_ppat (loop env) p
   in
-  try loop p; false with Exit -> true
+  try loop env p; false with Exit -> true
 
 let check_absent_variant env =
   iter_pattern
@@ -1855,7 +1879,7 @@ let check_absent_variant env =
 (* Duplicate types of values in the environment *)
 (* XXX Should we do something about global type variables too? *)
 
-let duplicate_ident_types loc caselist env =
+let duplicate_ident_types caselist env =
   let caselist =
     List.filter (fun {pc_lhs} -> contains_gadt env pc_lhs) caselist in
   let idents = all_idents_cases caselist in
@@ -2057,11 +2081,17 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
           default;
        ]
       in
+      let sloc =
+        { Location.loc_start = spat.ppat_loc.Location.loc_start;
+          loc_end = default_loc.Location.loc_end;
+          loc_ghost = true }
+      in
       let smatch =
-        Exp.match_ ~loc (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*")))
+        Exp.match_ ~loc:sloc
+          (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*")))
           scases
       in
-      let pat = Pat.var ~loc (mknoloc "*opt*") in
+      let pat = Pat.var ~loc:sloc (mknoloc "*opt*") in
       let body =
         Exp.let_ ~loc Nonrecursive ~attrs:[mknoloc "#default",PStr []]
           [Vb.mk spat smatch] sbody
@@ -2087,7 +2117,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
         let ty = expand_head env ty_fun in
         if List.memq ty seen then () else
         match ty.desc with
-          Tarrow (l, ty_arg, ty_fun, com) ->
+          Tarrow (_l, ty_arg, ty_fun, _com) ->
             (try unify_var env (newvar()) ty_arg with Unify _ -> assert false);
             lower_args (ty::seen) ty_fun
         | _ -> ()
@@ -2109,8 +2139,8 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
       begin_def ();
       let arg = type_exp env sarg in
       end_def ();
-      if is_nonexpansive arg then generalize arg.exp_type
-      else generalize_expansive env arg.exp_type;
+      if not (is_nonexpansive arg) then generalize_expansive env arg.exp_type;
+      generalize arg.exp_type;
       let rec split_cases vc ec = function
         | [] -> List.rev vc, List.rev ec
         | {pc_lhs = {ppat_desc=Ppat_exception p}} as c :: rest ->
@@ -2256,53 +2286,83 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
         | [] -> ()
       in
       check_duplicates lbl_exp_list;
-      let opt_exp =
-        match opt_exp, lbl_exp_list with
-          None, _ -> None
-        | Some exp, (lid, lbl, lbl_exp) :: _ ->
+      let opt_exp, label_definitions =
+        let (_lid, lbl, _lbl_exp) = List.hd lbl_exp_list in
+        let matching_label lbl =
+          List.find
+            (fun (_, lbl',_) -> lbl'.lbl_pos = lbl.lbl_pos)
+            lbl_exp_list
+        in
+        match opt_exp with
+          None ->
+            let label_definitions =
+              Array.map (fun lbl ->
+                  match matching_label lbl with
+                  | (lid, _lbl, lbl_exp) ->
+                      Overridden (lid, lbl_exp)
+                  | exception Not_found ->
+                      let present_indices =
+                        List.map (fun (_, lbl, _) -> lbl.lbl_pos) lbl_exp_list
+                      in
+                      let label_names = extract_label_names env ty_expected in
+                      let rec missing_labels n = function
+                          [] -> []
+                        | lbl :: rem ->
+                            if List.mem n present_indices
+                            then missing_labels (n + 1) rem
+                            else lbl :: missing_labels (n + 1) rem
+                      in
+                      let missing = missing_labels 0 label_names in
+                      raise(Error(loc, env, Label_missing missing)))
+                lbl.lbl_all
+            in
+            None, label_definitions
+        | Some exp ->
             let ty_exp = instance env exp.exp_type in
             let unify_kept lbl =
-              (* do not connect overridden labels *)
-              if List.for_all
-                  (fun (_, lbl',_) -> lbl'.lbl_pos <> lbl.lbl_pos)
-                  lbl_exp_list
-              then begin
-                let _, ty_arg1, ty_res1 = instance_label false lbl
-                and _, ty_arg2, ty_res2 = instance_label false lbl in
-                unify env ty_arg1 ty_arg2;
-                unify env (instance env ty_expected) ty_res2;
-                unify_exp_types exp.exp_loc env ty_exp ty_res1;
-              end in
-            Array.iter unify_kept lbl.lbl_all;
-            Some {exp with exp_type = ty_exp}
-        | _ -> assert false
+              match matching_label lbl with
+              | lid, _lbl, lbl_exp ->
+                  Overridden (lid, lbl_exp)
+              | exception Not_found -> begin
+                (* do not connect overridden labels *)
+                  let _, ty_arg1, ty_res1 = instance_label false lbl
+                  and _, ty_arg2, ty_res2 = instance_label false lbl in
+                  unify env ty_arg1 ty_arg2;
+                  unify env (instance env ty_expected) ty_res2;
+                  unify_exp_types exp.exp_loc env ty_exp ty_res1;
+                  Kept ty_arg1
+                end
+            in
+            let label_definitions = Array.map unify_kept lbl.lbl_all in
+            Some {exp with exp_type = ty_exp}, label_definitions
       in
       let num_fields =
         match lbl_exp_list with [] -> assert false
         | (_, lbl,_)::_ -> Array.length lbl.lbl_all in
-      if opt_sexp = None && List.length lid_sexp_list <> num_fields then begin
-        let present_indices =
-          List.map (fun (_, lbl, _) -> lbl.lbl_pos) lbl_exp_list in
-        let label_names = extract_label_names sexp env ty_expected in
-        let rec missing_labels n = function
-            [] -> []
-          | lbl :: rem ->
-              if List.mem n present_indices then missing_labels (n + 1) rem
-              else lbl :: missing_labels (n + 1) rem
-        in
-        let missing = missing_labels 0 label_names in
-        raise(Error(loc, env, Label_missing missing))
-      end
-      else if opt_sexp <> None && List.length lid_sexp_list = num_fields then
-        Location.prerr_warning loc Warnings.Useless_record_with;
+      let opt_exp =
+        if opt_sexp <> None && List.length lid_sexp_list = num_fields then
+          (Location.prerr_warning loc Warnings.Useless_record_with; None)
+        else opt_exp
+      in
+      let label_descriptions, representation =
+        let (_, { lbl_all; lbl_repres }, _) = List.hd lbl_exp_list in
+        lbl_all, lbl_repres
+      in
+      let fields =
+        Array.map2 (fun descr def -> descr, def)
+          label_descriptions label_definitions
+      in
       re {
-        exp_desc = Texp_record(lbl_exp_list, opt_exp);
+        exp_desc = Texp_record {
+            fields; representation;
+            extended_expression = opt_exp
+          };
         exp_loc = loc; exp_extra = [];
         exp_type = instance env ty_expected;
         exp_attributes = sexp.pexp_attributes;
         exp_env = env }
   | Pexp_field(srecord, lid) ->
-      let (record, label, _) = type_label_access env loc srecord lid in
+      let (record, label, _) = type_label_access env srecord lid in
       let (_, ty_arg, ty_res) = instance_label false label in
       unify_exp env record ty_res;
       rue {
@@ -2312,7 +2372,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
         exp_attributes = sexp.pexp_attributes;
         exp_env = env }
   | Pexp_setfield(srecord, lid, snewval) ->
-      let (record, label, opath) = type_label_access env loc srecord lid in
+      let (record, label, opath) = type_label_access env srecord lid in
       let ty_record = if opath = None then newvar () else record.exp_type in
       let (label_loc, label, newval) =
         type_label_exp false env loc ty_record (lid, label, snewval) in
@@ -2440,7 +2500,8 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
                 end_def ();
                 let tv = newvar () in
                 let gen = generalizable tv.level arg.exp_type in
-                unify_var env tv arg.exp_type;
+                (try unify_var env tv arg.exp_type with Unify trace ->
+                  raise(Error(arg.exp_loc, env, Expr_type_clash trace)));
                 gen
               end else true
             in
@@ -2454,7 +2515,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
                   && free_variables ~env ty' = [] ->
                 if not gen && (* first try a single coercion *)
                   let snap = snapshot () in
-                  let ty, b = enlarge_type env ty' in
+                  let ty, _b = enlarge_type env ty' in
                   try
                     force (); Ctype.unify env arg.exp_type ty; true
                   with Unify _ ->
@@ -2519,7 +2580,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
       begin try
         let (meth, exp, typ) =
           match obj.exp_desc with
-            Texp_ident(path, _, {val_kind = Val_self (meths, _, _, privty)}) ->
+            Texp_ident(_path, _, {val_kind = Val_self (meths, _, _, privty)}) ->
               obj_meths := Some meths;
               let (id, typ) =
                 filter_self_method env met Private meths privty
@@ -2528,7 +2589,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
                 Location.prerr_warning loc
                   (Warnings.Undeclared_virtual_method met);
               (Tmeth_val id, None, typ)
-          | Texp_ident(path, lid, {val_kind = Val_anc (methods, cl_num)}) ->
+          | Texp_ident(_path, lid, {val_kind = Val_anc (methods, cl_num)}) ->
               let method_id =
                 begin try List.assoc met methods with Not_found ->
                   let valid_methods = List.map fst methods in
@@ -2738,6 +2799,16 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
         exp_type = ty;
         exp_attributes = sexp.pexp_attributes;
         exp_env = env }
+  | Pexp_letexception(cd, sbody) ->
+      let (cd, newenv) = Typedecl.transl_exception env cd in
+      let body = type_expect newenv sbody ty_expected in
+      re {
+        exp_desc = Texp_letexception(cd, body);
+        exp_loc = loc; exp_extra = [];
+        exp_type = body.exp_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+
   | Pexp_assert (e) ->
       let cond = type_expect env e Predef.type_bool in
       let exp_type =
@@ -2834,6 +2905,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
         type_loc = loc;
         type_attributes = [];
         type_immediate = false;
+        type_unboxed = unboxed_false_default_false;
       }
       in
       Ident.set_current_time ty.level;
@@ -2866,21 +2938,21 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
             exp_extra =
             (Texp_newtype name, loc, sexp.pexp_attributes) :: body.exp_extra }
   | Pexp_pack m ->
-      let (p, nl, tl) =
+      let (p, nl) =
         match Ctype.expand_head env (instance env ty_expected) with
-          {desc = Tpackage (p, nl, tl)} ->
+          {desc = Tpackage (p, nl, _tl)} ->
             if !Clflags.principal &&
               (Ctype.expand_head env ty_expected).level < Btype.generic_level
             then
               Location.prerr_warning loc
                 (Warnings.Not_principal "this module packing");
-            (p, nl, tl)
+            (p, nl)
         | {desc = Tvar _} ->
             raise (Error (loc, env, Cannot_infer_signature))
         | _ ->
             raise (Error (loc, env, Not_a_packed_module ty_expected))
       in
-      let (modl, tl') = !type_package env m p nl tl in
+      let (modl, tl') = !type_package env m p nl in
       rue {
         exp_desc = Texp_pack modl;
         exp_loc = loc; exp_extra = [];
@@ -2977,7 +3049,7 @@ and type_function ?in_function loc attrs env ty_expected l caselist =
     exp_env = env }
 
 
-and type_label_access env loc srecord lid =
+and type_label_access env srecord lid =
   if !Clflags.principal then begin_def ();
   let record = type_exp ~recarg:Allowed env srecord in
   if !Clflags.principal then begin
@@ -3672,24 +3744,26 @@ and type_statement env sexp =
   begin_def();
   let exp = type_exp env sexp in
   end_def();
+  let ty = expand_head env exp.exp_type and tv = newvar() in
+  if is_Tvar ty && ty.level > tv.level then
+      Location.prerr_warning loc Warnings.Nonreturning_statement;
   if !Clflags.strict_sequence then
     let expected_ty = instance_def Predef.type_unit in
     unify_exp env exp expected_ty;
-    exp else
-  let ty = expand_head env exp.exp_type and tv = newvar() in
-  begin match ty.desc with
-  | Tarrow _ ->
-      Location.prerr_warning loc Warnings.Partial_application
-  | Tconstr (p, _, _) when Path.same p Predef.path_unit -> ()
-  | Tvar _ when ty.level > tv.level ->
-      Location.prerr_warning loc Warnings.Nonreturning_statement
-  | Tvar _ ->
-      add_delayed_check (fun () -> check_application_result env true exp)
-  | _ ->
-      Location.prerr_warning loc Warnings.Statement_type
-  end;
-  unify_var env tv ty;
-  exp
+    exp
+  else begin
+    begin match ty.desc with
+    | Tarrow _ ->
+        Location.prerr_warning loc Warnings.Partial_application
+    | Tconstr (p, _, _) when Path.same p Predef.path_unit -> ()
+    | Tvar _ ->
+        add_delayed_check (fun () -> check_application_result env true exp)
+    | _ ->
+        Location.prerr_warning loc Warnings.Statement_type
+    end;
+    unify_var env tv ty;
+    exp
+  end
 
 (* Typing of match cases *)
 
@@ -3705,30 +3779,36 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
     then correct_levels ty_arg else ty_arg
   and ty_res, env =
     if has_gadts && not !Clflags.principal then
-      correct_levels ty_res, duplicate_ident_types loc caselist env
+      correct_levels ty_res, duplicate_ident_types caselist env
     else ty_res, env
   in
-  let do_init = has_gadts || List.length caselist > 1 in
+  let rec is_var spat =
+    match spat.ppat_desc with
+      Ppat_any | Ppat_var _ -> true
+    | Ppat_alias (spat, _) -> is_var spat
+    | _ -> false in
+  let needs_exhaust_check =
+    match caselist with
+      [{pc_rhs = {pexp_desc = Pexp_unreachable}}] -> true
+    | [{pc_lhs}] when is_var pc_lhs -> false
+    | _ -> true
+  in
+  let init_env () =
+    (* raise level for existentials *)
+    begin_def ();
+    Ident.set_current_time (get_current_level ());
+    let lev = Ident.current_time () in
+    Ctype.init_def (lev+1000);                 (* up to 1000 existentials *)
+    (lev, Env.add_gadt_instance_level lev env)
+  in
   let lev, env =
-    if do_init then begin
-      (* raise level for existentials *)
-      begin_def ();
-      Ident.set_current_time (get_current_level ());
-      let lev = Ident.current_time () in
-      Ctype.init_def (lev+1000);                 (* up to 1000 existentials *)
-      (lev, Env.add_gadt_instance_level lev env)
-    end else (get_current_level (), env)
+    if has_gadts then init_env () else (get_current_level (), env)
   in
 (*  if has_gadts then
     Format.printf "lev = %d@.%a@." lev Printtyp.raw_type_expr ty_res; *)
   (* Do we need to propagate polymorphism *)
   let propagate =
-    !Clflags.principal || do_init || (repr ty_arg).level = generic_level ||
-    let rec is_var spat =
-      match spat.ppat_desc with
-        Ppat_any | Ppat_var _ -> true
-      | Ppat_alias (spat, _) -> is_var spat
-      | _ -> false in
+    !Clflags.principal || has_gadts || (repr ty_arg).level = generic_level ||
     match caselist with
       [{pc_lhs}] when is_var pc_lhs -> false
     | _ -> true in
@@ -3823,25 +3903,31 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
     let ty_res' = instance env ty_res in
     List.iter (fun c -> unify_exp env c.c_rhs ty_res') cases
   end;
+  let do_init = has_gadts || needs_exhaust_check in
+  let lev, env =
+    if do_init && not has_gadts then init_env () else lev, env in
+  let ty_arg_check =
+    if do_init then
+      (* Hack: use for_saving to copy variables too *)
+      Subst.type_expr (Subst.for_saving Subst.identity) ty_arg
+    else ty_arg
+  in
   let partial =
     if partial_flag then
-      check_partial ~lev env ty_arg loc cases
+      check_partial ~lev env ty_arg_check loc cases
     else
       Partial
   in
-  let unused_check ty_arg () =
+  let unused_check () =
     List.iter (fun (pat, (env, _)) -> check_absent_variant env pat)
       pat_env_list;
-    check_unused ~lev env (instance env ty_arg) cases ;
+    check_unused ~lev env (instance env ty_arg_check) cases ;
     Parmatch.check_ambiguous_bindings cases
   in
   if contains_polyvars || do_init then
-    let ty_arg_check =
-      (* Hack: use for_saving to copy variables too *)
-      Subst.type_expr (Subst.for_saving Subst.identity) ty_arg in
-    add_delayed_check (unused_check ty_arg_check)
+    add_delayed_check unused_check
   else
-    unused_check ty_arg ();
+    unused_check ();
   (* Check for unused cases, do not delay because of gadts *)
   if do_init then begin
     end_def ();
@@ -4049,7 +4135,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
 
 let type_binding env rec_flag spat_sexp_list scope =
   Typetexp.reset_type_variables();
-  let (pat_exp_list, new_env, unpacks) =
+  let (pat_exp_list, new_env, _unpacks) =
     type_let
       ~check:(fun s -> Warnings.Unused_value_declaration s)
       ~check_strict:(fun s -> Warnings.Unused_value_declaration s)
@@ -4058,7 +4144,7 @@ let type_binding env rec_flag spat_sexp_list scope =
   (pat_exp_list, new_env)
 
 let type_let env rec_flag spat_sexp_list scope =
-  let (pat_exp_list, new_env, unpacks) =
+  let (pat_exp_list, new_env, _unpacks) =
     type_let env rec_flag spat_sexp_list scope false in
   (pat_exp_list, new_env)
 
@@ -4069,12 +4155,12 @@ let type_expression env sexp =
   begin_def();
   let exp = type_exp env sexp in
   end_def();
-  if is_nonexpansive exp then generalize exp.exp_type
-  else generalize_expansive env exp.exp_type;
+  if not (is_nonexpansive exp) then generalize_expansive env exp.exp_type;
+  generalize exp.exp_type;
   match sexp.pexp_desc with
     Pexp_ident lid ->
       (* Special case for keeping type variables when looking-up a variable *)
-      let (path, desc) = Env.lookup_value lid.txt env in
+      let (_path, desc) = Env.lookup_value lid.txt env in
       {exp with exp_type = desc.val_type}
   | _ -> exp
 
diff --git a/typing/typecore.mli b/typing/typecore.mli
index 40448305..85fd0a82 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -141,7 +141,7 @@ val type_object:
    Typedtree.class_structure * Types.class_signature * string list) ref
 val type_package:
   (Env.t -> Parsetree.module_expr -> Path.t -> Longident.t list ->
-  type_expr list -> Typedtree.module_expr * type_expr list) ref
+  Typedtree.module_expr * type_expr list) ref
 
 val create_package_type : Location.t -> Env.t ->
   Longident.t * (Longident.t * Parsetree.core_type) list ->
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 0d6fa278..25afa6b5 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -55,11 +55,27 @@ type error =
   | Cannot_unbox_or_untag_type of native_repr_kind
   | Deep_unbox_or_untag_attribute of native_repr_kind
   | Bad_immediate_attribute
+  | Bad_unboxed_attribute of string
+  | Wrong_unboxed_type_float
+  | Boxed_and_unboxed
 
 open Typedtree
 
 exception Error of Location.t * error
 
+(* Note: do not factor the branches in the following pattern-matching:
+   the records must be constants for the compiler to do sharing on them.
+*)
+let get_unboxed_from_attributes sdecl =
+  let unboxed = Builtin_attributes.has_unboxed sdecl.ptype_attributes in
+  let boxed = Builtin_attributes.has_boxed sdecl.ptype_attributes in
+  match boxed, unboxed, !Clflags.unboxed_types with
+  | true, true, _ -> raise (Error(sdecl.ptype_loc, Boxed_and_unboxed))
+  | true, false, _ -> unboxed_false_default_false
+  | false, true, _ -> unboxed_true_default_false
+  | false, false, false -> unboxed_false_default_true
+  | false, false, true -> unboxed_true_default_true
+
 (* Enter all declared types in the environment as abstract types *)
 
 let enter_type env sdecl id =
@@ -77,6 +93,7 @@ let enter_type env sdecl id =
       type_loc = sdecl.ptype_loc;
       type_attributes = sdecl.ptype_attributes;
       type_immediate = false;
+      type_unboxed = unboxed_false_default_false;
     }
   in
   Env.add_type ~check:true id decl env
@@ -91,12 +108,38 @@ let update_type temp_env env id loc =
       with Ctype.Unify trace ->
         raise (Error(loc, Type_clash (env, trace)))
 
-(* Determine if a type is (an abbreviation for) the type "float" *)
 (* We use the Ctype.expand_head_opt version of expand_head to get access
    to the manifest type of private abbreviations. *)
+let rec get_unboxed_type_representation env ty fuel =
+  if fuel < 0 then None else
+  let ty = Ctype.repr (Ctype.expand_head_opt env ty) in
+  match ty.desc with
+  | Tconstr (p, args, _) ->
+    begin match Env.find_type p env with
+    | exception Not_found -> Some ty
+    | {type_unboxed = {unboxed = false}} -> Some ty
+    | {type_params; type_kind =
+         Type_record ([{ld_type = ty2; _}], _)
+       | Type_variant [{cd_args = Cstr_tuple [ty2]; _}]
+       | Type_variant [{cd_args = Cstr_record [{ld_type = ty2; _}]; _}]}
+
+         -> get_unboxed_type_representation env
+             (Ctype.apply env type_params ty2 args) (fuel - 1)
+    | {type_kind=Type_abstract} -> None
+          (* This case can occur when checking a recursive unboxed type
+             declaration. *)
+    | _ -> assert false (* only the above can be unboxed *)
+    end
+  | _ -> Some ty
+
+let get_unboxed_type_representation env ty =
+  get_unboxed_type_representation env ty 100000
+;;
+
+(* Determine if a type's values are represented by floats at run-time. *)
 let is_float env ty =
-  match Ctype.repr (Ctype.expand_head_opt env ty) with
-    {desc = Tconstr(p, _, _)} -> Path.same p Predef.path_float
+  match get_unboxed_type_representation env ty with
+    Some {desc = Tconstr(p, _, _); _} -> Path.same p Predef.path_float
   | _ -> false
 
 (* Determine if a type definition defines a fixed type. (PW) *)
@@ -157,7 +200,7 @@ let make_params env params =
   in
     List.map make_param params
 
-let transl_labels loc env closed lbls =
+let transl_labels env closed lbls =
   assert (lbls <> []);
   let all_labels = ref StringSet.empty in
   List.iter
@@ -189,21 +232,21 @@ let transl_labels loc env closed lbls =
       lbls in
   lbls, lbls'
 
-let transl_constructor_arguments loc env closed = function
+let transl_constructor_arguments env closed = function
   | Pcstr_tuple l ->
       let l = List.map (transl_simple_type env closed) l in
       Types.Cstr_tuple (List.map (fun t -> t.ctyp_type) l),
       Cstr_tuple l
   | Pcstr_record l ->
-      let lbls, lbls' = transl_labels loc env closed l in
+      let lbls, lbls' = transl_labels env closed l in
       Types.Cstr_record lbls',
       Cstr_record lbls
 
-let make_constructor loc env type_path type_params sargs sret_type =
+let make_constructor env type_path type_params sargs sret_type =
   match sret_type with
   | None ->
       let args, targs =
-        transl_constructor_arguments loc env true sargs
+        transl_constructor_arguments env true sargs
       in
         targs, None, args, None
   | Some sret_type ->
@@ -212,7 +255,7 @@ let make_constructor loc env type_path type_params sargs sret_type =
       let z = narrow () in
       reset_type_variables ();
       let args, targs =
-        transl_constructor_arguments loc env false sargs
+        transl_constructor_arguments env false sargs
       in
       let tret_type = transl_simple_type env false sret_type in
       let ret_type = tret_type.ctyp_type in
@@ -226,6 +269,31 @@ let make_constructor loc env type_path type_params sargs sret_type =
       widen z;
       targs, Some tret_type, args, Some ret_type
 
+(* Check that the argument to a GADT constructor is compatible with unboxing
+   the type, given the existential variables introduced by this constructor. *)
+let rec check_unboxed_gadt_arg loc ex env ty =
+  match get_unboxed_type_representation env ty with
+  | Some {desc = Tvar _; id} ->
+    let f t = (Btype.repr t).id = id in
+    if List.exists f ex then raise(Error(loc, Wrong_unboxed_type_float))
+  | Some {desc = Tarrow _ | Ttuple _ | Tpackage _ | Tobject _ | Tnil
+                 | Tvariant _; _} ->
+    ()
+    (* A comment in [Translcore.transl_exp0] claims the above cannot be
+       represented by floats. *)
+  | Some {desc = Tconstr (p, args, _); _} ->
+    let tydecl = Env.find_type p env in
+    assert (not tydecl.type_unboxed.unboxed);
+    if tydecl.type_kind = Type_abstract then
+      List.iter (check_unboxed_gadt_arg loc ex env) args
+  | Some {desc = Tfield _ | Tlink _ | Tsubst _; _} -> assert false
+  | Some {desc = Tunivar _; _} -> ()
+  | Some {desc = Tpoly (t2, _); _} -> check_unboxed_gadt_arg loc ex env t2
+  | None -> ()
+      (* This case is tricky: the argument is another (or the same) type
+         in the same recursive definition. In this case we don't have to
+         check because we will also check that other type for correctness. *)
+
 let transl_declaration env sdecl id =
   (* Bind type parameters *)
   reset_type_variables();
@@ -238,9 +306,54 @@ let transl_declaration env sdecl id =
       transl_simple_type env false sty', loc)
     sdecl.ptype_cstrs
   in
+  let raw_status = get_unboxed_from_attributes sdecl in
+  if raw_status.unboxed && not raw_status.default then begin
+    match sdecl.ptype_kind with
+    | Ptype_abstract ->
+        raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
+                      "it is abstract"))
+    | Ptype_variant [{pcd_args = Pcstr_tuple []; _}] ->
+      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
+                    "its constructor has no argument"))
+    | Ptype_variant [{pcd_args = Pcstr_tuple [_]; _}] -> ()
+    | Ptype_variant [{pcd_args = Pcstr_tuple _; _}] ->
+      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
+                    "its constructor has more than one argument"))
+    | Ptype_variant [{pcd_args = Pcstr_record
+                        [{pld_mutable=Immutable; _}]; _}] -> ()
+    | Ptype_variant [{pcd_args = Pcstr_record [{pld_mutable=Mutable; _}]; _}] ->
+      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute "it is mutable"))
+    | Ptype_variant [{pcd_args = Pcstr_record _; _}] ->
+      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
+                    "its constructor has more than one argument"))
+    | Ptype_variant _ ->
+      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
+                    "it has more than one constructor"))
+    | Ptype_record [{pld_mutable=Immutable; _}] -> ()
+    | Ptype_record [{pld_mutable=Mutable; _}] ->
+      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
+                    "it is mutable"))
+    | Ptype_record _ ->
+      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
+                    "it has more than one field"))
+    | Ptype_open ->
+      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
+                    "extensible variant types cannot be unboxed"))
+  end;
+  let unboxed_status =
+    match sdecl.ptype_kind with
+    | Ptype_variant [{pcd_args = Pcstr_tuple [_]; _}]
+      | Ptype_variant [{pcd_args = Pcstr_record
+                          [{pld_mutable = Immutable; _}]; _}]
+      | Ptype_record [{pld_mutable = Immutable; _}] ->
+    raw_status
+    | _ -> (* The type is not unboxable, mark it as boxed *)
+      unboxed_false_default_false
+  in
+  let unbox = unboxed_status.unboxed in
   let (tkind, kind) =
     match sdecl.ptype_kind with
-        Ptype_abstract -> Ttype_abstract, Type_abstract
+      | Ptype_abstract -> Ttype_abstract, Type_abstract
       | Ptype_variant scstrs ->
         assert (scstrs <> []);
         let all_constrs = ref StringSet.empty in
@@ -251,15 +364,29 @@ let transl_declaration env sdecl id =
             all_constrs := StringSet.add name !all_constrs)
           scstrs;
         if List.length
-          (List.filter (fun cd -> cd.pcd_args <> Pcstr_tuple []) scstrs)
-          > (Config.max_tag + 1) then
+            (List.filter (fun cd -> cd.pcd_args <> Pcstr_tuple []) scstrs)
+           > (Config.max_tag + 1) then
           raise(Error(sdecl.ptype_loc, Too_many_constructors));
         let make_cstr scstr =
           let name = Ident.create scstr.pcd_name.txt in
           let targs, tret_type, args, ret_type =
-            make_constructor scstr.pcd_loc env (Path.Pident id) params
+            make_constructor env (Path.Pident id) params
                              scstr.pcd_args scstr.pcd_res
           in
+          if unbox then begin
+            (* Cannot unbox a type when the argument can be both float and
+               non-float because it interferes with the dynamic float array
+               optimization. This can only happen when the type is a GADT
+               and the argument is an existential type variable or an
+               unboxed (or abstract) type constructor applied to some
+               existential type variable. Of course we also have to rule
+               out any abstract type constructor applied to anything that
+               might be an existential type variable. *)
+            match Datarepr.constructor_existentials args ret_type with
+            | _, [] -> ()
+            | [argty], ex -> check_unboxed_gadt_arg sdecl.ptype_loc ex env argty
+            | _ -> assert false
+          end;
           let tcstr =
             { cd_id = name;
               cd_name = scstr.pcd_name;
@@ -280,9 +407,10 @@ let transl_declaration env sdecl id =
         let tcstrs, cstrs = List.split (List.map make_cstr scstrs) in
           Ttype_variant tcstrs, Type_variant cstrs
       | Ptype_record lbls ->
-          let lbls, lbls' = transl_labels sdecl.ptype_loc env true lbls in
+          let lbls, lbls' = transl_labels env true lbls in
           let rep =
-            if List.for_all (fun l -> is_float env l.Types.ld_type) lbls'
+            if unbox then Record_unboxed false
+            else if List.for_all (fun l -> is_float env l.Types.ld_type) lbls'
             then Record_float
             else Record_regular
           in
@@ -307,6 +435,7 @@ let transl_declaration env sdecl id =
         type_loc = sdecl.ptype_loc;
         type_attributes = sdecl.ptype_attributes;
         type_immediate = false;
+        type_unboxed = unboxed_status;
       } in
 
   (* Check constraints *)
@@ -320,7 +449,7 @@ let transl_declaration env sdecl id =
     Ctype.end_def ();
   (* Add abstract row *)
     if is_fixed_type sdecl then begin
-      let (p, _) =
+      let p =
         try Env.lookup_type (Longident.Lident(Ident.name id ^ "#row")) env
         with Not_found -> assert false in
       set_fixed_row env sdecl.ptype_loc p decl
@@ -492,9 +621,9 @@ let check_abbrev env sdecl (id, decl) =
 
 let check_well_founded env loc path to_check ty =
   let visited = ref TypeMap.empty in
-  let rec check ty0 exp_nodes ty =
+  let rec check ty0 parents ty =
     let ty = Btype.repr ty in
-    if TypeSet.mem ty exp_nodes then begin
+    if TypeSet.mem ty parents then begin
       (*Format.eprintf "@[%a@]@." Printtyp.raw_type_expr ty;*)
       if match ty0.desc with
       | Tconstr (p, _, _) -> Path.same p path
@@ -502,41 +631,51 @@ let check_well_founded env loc path to_check ty =
       then raise (Error (loc, Recursive_abbrev (Path.name path)))
       else raise (Error (loc, Cycle_in_def (Path.name path, ty0)))
     end;
-    let (fini, exp_nodes) =
+    let (fini, parents) =
       try
         let prev = TypeMap.find ty !visited in
-        if TypeSet.subset exp_nodes prev then (true, exp_nodes) else
-        (false, TypeSet.union exp_nodes prev)
+        if TypeSet.subset parents prev then (true, parents) else
+        (false, TypeSet.union parents prev)
       with Not_found ->
-        (false, exp_nodes)
+        (false, parents)
     in
-    let snap = Btype.snapshot () in
-    if fini then () else try
-      visited := TypeMap.add ty exp_nodes !visited;
+    if fini then () else
+    let rec_ok =
       match ty.desc with
-      | Tconstr(p, args, _)
-        when not (TypeSet.is_empty exp_nodes) || to_check p ->
+        Tconstr(p,_,_) ->
+          !Clflags.recursive_types && Ctype.is_contractive env p
+      | Tobject _ | Tvariant _ -> true
+      | _ -> !Clflags.recursive_types
+    in
+    let visited' = TypeMap.add ty parents !visited in
+    let arg_exn =
+      try
+        visited := visited';
+        let parents =
+          if rec_ok then TypeSet.empty else TypeSet.add ty parents in
+        Btype.iter_type_expr (check ty0 parents) ty;
+        None
+      with e ->
+        visited := visited'; Some e
+    in
+    match ty.desc with
+    | Tconstr(p, _, _) when arg_exn <> None || to_check p ->
+        if to_check p then may raise arg_exn
+        else Btype.iter_type_expr (check ty0 TypeSet.empty) ty;
+        begin try
           let ty' = Ctype.try_expand_once_opt env ty in
-          let ty0 = if TypeSet.is_empty exp_nodes then ty else ty0 in
-          check ty0 (TypeSet.add ty exp_nodes) ty'
-      | _ -> raise Ctype.Cannot_expand
-    with
-    | Ctype.Cannot_expand ->
-        let rec_ok =
-          match ty.desc with
-            Tconstr(p,_,_) ->
-              !Clflags.recursive_types && Ctype.is_contractive env p
-          | Tobject _ | Tvariant _ -> true
-          | _ -> !Clflags.recursive_types
-        in
-        let nodes =
-          if rec_ok then TypeSet.empty else exp_nodes in
-        Btype.iter_type_expr (check ty0 nodes) ty
-    | Ctype.Unify _ ->
-        (* Will be detected by check_recursion *)
-        Btype.backtrack snap
+          let ty0 = if TypeSet.is_empty parents then ty else ty0 in
+          check ty0 (TypeSet.add ty parents) ty'
+        with
+          Ctype.Cannot_expand -> may raise arg_exn
+        end
+    | _ -> may raise arg_exn
   in
-  Ctype.wrap_trace_gadt_instances env (check ty TypeSet.empty) ty
+  let snap = Btype.snapshot () in
+  try Ctype.wrap_trace_gadt_instances env (check ty TypeSet.empty) ty
+  with Ctype.Unify _ ->
+    (* Will be detected by check_recursion *)
+    Btype.backtrack snap
 
 let check_well_founded_manifest env loc path decl =
   if decl.type_manifest = None then () else
@@ -688,6 +827,8 @@ let compute_variance env visited vari ty =
                     null [May_pos; May_neg; May_weak]
                 in
                 let v = inter vari upper in
+                (* cf PR#7269:
+                   if List.length tyl > 1 then upper else inter vari upper *)
                 List.iter (compute_variance_rec v) tyl
             | _ -> ())
           row.row_fields;
@@ -741,7 +882,7 @@ let compute_variance_type env check (required, loc) decl tyl =
     if fvl = [] then () else
     let tvl2 = ref TypeMap.empty in
     List.iter2
-      (fun ty (p,n,i) ->
+      (fun ty (p,n,_) ->
         if Btype.is_Tvar ty then () else
         let v =
           if p then if n then full else covariant else conjugate covariant in
@@ -823,7 +964,7 @@ let compute_variance_gadt env check (required, loc as rloc) decl
           let fvl = List.map (Ctype.free_variables ?env:None) tyl in
           let _ =
             List.fold_left2
-              (fun (fv1,fv2) ty (c,n,i) ->
+              (fun (fv1,fv2) ty (c,n,_) ->
                 match fv2 with [] -> assert false
                 | fv :: fv2 ->
                     (* fv1 @ fv2 = free_variables of other parameters *)
@@ -881,17 +1022,23 @@ let compute_variance_decl env check decl (required, _ as rloc) =
         (mn @ List.map (fun {Types.ld_mutable; ld_type} ->
              (ld_mutable = Mutable, ld_type)) ftl)
 
-let is_sharp id =
+let is_hash id =
   let s = Ident.name id in
   String.length s > 0 && s.[0] = '#'
 
 let marked_as_immediate decl =
-  List.exists
-    (fun (loc, _) -> loc.txt = "immediate")
-    decl.type_attributes
+  Builtin_attributes.immediate decl.type_attributes
 
 let compute_immediacy env tdecl =
   match (tdecl.type_kind, tdecl.type_manifest) with
+  | (Type_variant [{cd_args = Cstr_tuple [arg]; _}], _)
+    | (Type_variant [{cd_args = Cstr_record [{ld_type = arg; _}]; _}], _)
+    | (Type_record ([{ld_type = arg; _}], _), _)
+  when tdecl.type_unboxed.unboxed ->
+    begin match get_unboxed_type_representation env arg with
+    | Some argrepr -> not (Ctype.maybe_pointer_type env argrepr)
+    | None -> false
+    end
   | (Type_variant (_ :: _ as cstrs), _) ->
     not (List.exists (fun c -> c.Types.cd_args <> Types.Cstr_tuple []) cstrs)
   | (Type_abstract, Some(typ)) ->
@@ -915,14 +1062,14 @@ let rec compute_properties_fixpoint env decls required variances immediacies =
   in
   let new_variances =
     List.map2
-      (fun (id, decl) -> compute_variance_decl new_env false decl)
+      (fun (_id, decl) -> compute_variance_decl new_env false decl)
       new_decls required
   in
   let new_variances =
     List.map2 (List.map2 Variance.union) new_variances variances in
   let new_immediacies =
     List.map
-      (fun (id, decl) -> compute_immediacy new_env decl)
+      (fun (_id, decl) -> compute_immediacy new_env decl)
       new_decls
   in
   if new_variances <> variances || new_immediacies <> immediacies then
@@ -941,13 +1088,13 @@ let rec compute_properties_fixpoint env decls required variances immediacies =
       else ())
       new_decls;
     List.iter2
-      (fun (id, decl) req -> if not (is_sharp id) then
+      (fun (id, decl) req -> if not (is_hash id) then
         ignore (compute_variance_decl new_env true decl req))
       new_decls required;
     new_decls, new_env
   end
 
-let init_variance (id, decl) =
+let init_variance (_id, decl) =
   List.map (fun _ -> Variance.null) decl.type_params
 
 let add_injectivity =
@@ -962,7 +1109,7 @@ let add_injectivity =
 let compute_variance_decls env cldecls =
   let decls, required =
     List.fold_right
-      (fun (obj_id, obj_abbr, cl_abbr, clty, cltydef, ci) (decls, req) ->
+      (fun (obj_id, obj_abbr, _cl_abbr, _clty, _cltydef, ci) (decls, req) ->
         let variance = List.map snd ci.ci_params in
         (obj_id, obj_abbr) :: decls,
         (add_injectivity variance, ci.ci_loc) :: req)
@@ -1162,7 +1309,7 @@ let transl_type_decl env rec_flag sdecl_list =
   (* Keep original declaration *)
   let final_decls =
     List.map2
-      (fun tdecl (id2, decl) ->
+      (fun tdecl (_id2, decl) ->
         { tdecl with typ_type = decl }
       ) tdecls final_decls
   in
@@ -1178,7 +1325,7 @@ let transl_extension_constructor env type_path type_params
     match sext.pext_kind with
       Pext_decl(sargs, sret_type) ->
         let targs, tret_type, args, ret_type =
-          make_constructor sext.pext_loc env type_path typext_params
+          make_constructor env type_path typext_params
             sargs sret_type
         in
           args, ret_type, Text_decl(targs, tret_type)
@@ -1475,6 +1622,18 @@ let rec parse_native_repr_attributes env core_type ty ~global_repr =
   | Ptyp_arrow _, _, _ | _, Tarrow _, _ -> assert false
   | _ -> ([], make_native_repr env core_type ty ~global_repr)
 
+
+let check_unboxable env loc ty =
+  let ty = Ctype.repr (Ctype.expand_head_opt env ty) in
+  try match ty.desc with
+  | Tconstr (p, _, _) ->
+    let tydecl = Env.find_type p env in
+    if tydecl.type_unboxed.unboxed then
+      Location.prerr_warning loc
+        (Warnings.Unboxable_type_in_prim_decl (Path.name p))
+  | _ -> ()
+  with Not_found -> ()
+
 (* Translate a value declaration *)
 let transl_value_decl env loc valdecl =
   let cty = Typetexp.transl_type_scheme env valdecl.pval_type in
@@ -1509,6 +1668,7 @@ let transl_value_decl env loc valdecl =
       && prim.prim_arity > 5
       && prim.prim_native_name = ""
       then raise(Error(valdecl.pval_type.ptyp_loc, Missing_native_external));
+      Btype.iter_type_expr (check_unboxable env loc) ty;
       { val_type = ty; val_kind = Val_prim prim; Types.val_loc = loc;
         val_attributes = valdecl.pval_attributes }
   in
@@ -1569,11 +1729,16 @@ let transl_with_constraint env id row_path orig_decl sdecl =
   && sdecl.ptype_private = Private then
     Location.prerr_warning sdecl.ptype_loc
       (Warnings.Deprecated "spurious use of private");
+  let type_kind, type_unboxed =
+    if arity_ok && man <> None then
+      orig_decl.type_kind, orig_decl.type_unboxed
+    else
+      Type_abstract, unboxed_false_default_false
+  in
   let decl =
     { type_params = params;
       type_arity = List.length params;
-      type_kind =
-        if arity_ok && man <> None then orig_decl.type_kind else Type_abstract;
+      type_kind;
       type_private = priv;
       type_manifest = man;
       type_variance = [];
@@ -1581,6 +1746,7 @@ let transl_with_constraint env id row_path orig_decl sdecl =
       type_loc = sdecl.ptype_loc;
       type_attributes = sdecl.ptype_attributes;
       type_immediate = false;
+      type_unboxed;
     }
   in
   begin match row_path with None -> ()
@@ -1628,12 +1794,13 @@ let abstract_type_decl arity =
       type_loc = Location.none;
       type_attributes = [];
       type_immediate = false;
+      type_unboxed = unboxed_false_default_false;
      } in
   Ctype.end_def();
   generalize_decl decl;
   decl
 
-let approx_type_decl env sdecl_list =
+let approx_type_decl sdecl_list =
   List.map
     (fun sdecl ->
       (Ident.create sdecl.ptype_name.txt,
@@ -1684,7 +1851,7 @@ let explain_unbound_single ppf tv ty =
       let row = Btype.row_repr row in
       if row.row_more == tv then trivial ty else
       explain_unbound ppf tv row.row_fields
-        (fun (l,f) -> match Btype.row_field_repr f with
+        (fun (_l,f) -> match Btype.row_field_repr f with
           Rpresent (Some t) -> t
         | Reither (_,[t],_,_) -> t
         | Reither (_,tl,_,_) -> Btype.newgenty (Ttuple tl)
@@ -1873,6 +2040,14 @@ let report_error ppf = function
       fprintf ppf "@[%s@ %s@]"
         "Types marked with the immediate attribute must be"
         "non-pointer types like int or bool"
+  | Bad_unboxed_attribute msg ->
+      fprintf ppf "@[This type cannot be unboxed because@ %s.@]" msg
+  | Wrong_unboxed_type_float ->
+      fprintf ppf "@[This type cannot be unboxed because@ \
+                   it might contain both float and non-float values.@ \
+                   You should annotate it with [%@%@ocaml.boxed].@]"
+  | Boxed_and_unboxed ->
+      fprintf ppf "@[A type cannot be boxed and unboxed at the same time.@]"
 
 let () =
   Location.register_error_of_exn
diff --git a/typing/typedecl.mli b/typing/typedecl.mli
index fa57b17c..db4875f9 100644
--- a/typing/typedecl.mli
+++ b/typing/typedecl.mli
@@ -40,7 +40,7 @@ val transl_with_constraint:
 
 val abstract_type_decl: int -> type_declaration
 val approx_type_decl:
-    Env.t -> Parsetree.type_declaration list ->
+    Parsetree.type_declaration list ->
                                   (Ident.t * type_declaration) list
 val check_recmod_typedecl:
     Env.t -> Location.t -> Ident.t list -> Path.t -> type_declaration -> unit
@@ -59,6 +59,10 @@ val compute_variance_decls:
     (Types.type_declaration * Types.type_declaration *
      Types.class_declaration * Types.class_type_declaration) list
 
+(* for typeopt.ml *)
+val get_unboxed_type_representation: Env.t -> type_expr -> type_expr option
+
+
 type native_repr_kind = Unboxed | Untagged
 
 type error =
@@ -92,6 +96,9 @@ type error =
   | Cannot_unbox_or_untag_type of native_repr_kind
   | Deep_unbox_or_untag_attribute of native_repr_kind
   | Bad_immediate_attribute
+  | Bad_unboxed_attribute of string
+  | Wrong_unboxed_type_float
+  | Boxed_and_unboxed
 
 exception Error of Location.t * error
 
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index f3649f1e..d06a13b9 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -38,6 +38,7 @@ type pattern =
 and pat_extra =
   | Tpat_constraint of core_type
   | Tpat_type of Path.t * Longident.t loc
+  | Tpat_open of Path.t * Longident.t loc * Env.t
   | Tpat_unpack
 
 and pattern_desc =
@@ -84,9 +85,11 @@ and expression_desc =
   | Texp_construct of
       Longident.t loc * constructor_description * expression list
   | Texp_variant of label * expression option
-  | Texp_record of
-      (Longident.t loc * label_description * expression) list *
-        expression option
+  | Texp_record of {
+      fields : ( Types.label_description * record_label_definition ) array;
+      representation : Types.record_representation;
+      extended_expression : expression option;
+    }
   | Texp_field of expression * Longident.t loc * label_description
   | Texp_setfield of
       expression * Longident.t loc * label_description * expression
@@ -103,6 +106,7 @@ and expression_desc =
   | Texp_setinstvar of Path.t * Path.t * string loc * expression
   | Texp_override of Path.t * (Path.t * string loc * expression) list
   | Texp_letmodule of Ident.t * string loc * module_expr * expression
+  | Texp_letexception of extension_constructor * expression
   | Texp_assert of expression
   | Texp_lazy of expression
   | Texp_object of class_structure * string list
@@ -121,6 +125,10 @@ and case =
      c_rhs: expression;
     }
 
+and record_label_definition =
+  | Kept of Types.type_expr
+  | Overridden of Longident.t loc * expression
+
 (* Value expressions for the class language *)
 
 and class_expr =
@@ -505,7 +513,7 @@ and 'a class_infos =
     ci_id_class: Ident.t;
     ci_id_class_type: Ident.t;
     ci_id_object: Ident.t;
-    ci_id_typesharp: Ident.t;
+    ci_id_typehash: Ident.t;
     ci_expr: 'a;
     ci_decl: Types.class_declaration;
     ci_type_decl: Types.class_type_declaration;
@@ -518,10 +526,10 @@ and 'a class_infos =
 let iter_pattern_desc f = function
   | Tpat_alias(p, _, _) -> f p
   | Tpat_tuple patl -> List.iter f patl
-  | Tpat_construct(_, cstr, patl) -> List.iter f patl
+  | Tpat_construct(_, _, patl) -> List.iter f patl
   | Tpat_variant(_, pat, _) -> may f pat
   | Tpat_record (lbl_pat_list, _) ->
-      List.iter (fun (_, lbl, pat) -> f pat) lbl_pat_list
+      List.iter (fun (_, _, pat) -> f pat) lbl_pat_list
   | Tpat_array patl -> List.iter f patl
   | Tpat_or(p1, p2, _) -> f p1; f p2
   | Tpat_lazy p -> f p
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index ec697cdd..c773083b 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -56,6 +56,7 @@ and pat_extra =
                            where [disjunction] is a [Tpat_or _] representing the
                            branches of [tconst].
          *)
+  | Tpat_open of Path.t * Longident.t loc * Env.t
   | Tpat_unpack
         (** (module P)     { pat_desc  = Tpat_var "P"
                            ; pat_extra = (Tpat_unpack, _, _) :: ... }
@@ -185,9 +186,22 @@ and expression_desc =
             C (E1, ..., En)  [E1;...;En]
          *)
   | Texp_variant of label * expression option
-  | Texp_record of
-      (Longident.t loc * label_description * expression) list *
-        expression option
+  | Texp_record of {
+      fields : ( Types.label_description * record_label_definition ) array;
+      representation : Types.record_representation;
+      extended_expression : expression option;
+    }
+        (** { l1=P1; ...; ln=Pn }           (extended_expression = None)
+            { E0 with l1=P1; ...; ln=Pn }   (extended_expression = Some E0)
+
+            Invariant: n > 0
+
+            If the type is { l1: t1; l2: t2 }, the expression
+            { E0 with t2=P2 } is represented as
+            Texp_record
+              { fields = [| l1, Kept t1; l2 Override P2 |]; representation;
+                extended_expression = Some E0 }
+        *)
   | Texp_field of expression * Longident.t loc * label_description
   | Texp_setfield of
       expression * Longident.t loc * label_description * expression
@@ -204,6 +218,7 @@ and expression_desc =
   | Texp_setinstvar of Path.t * Path.t * string loc * expression
   | Texp_override of Path.t * (Path.t * string loc * expression) list
   | Texp_letmodule of Ident.t * string loc * module_expr * expression
+  | Texp_letexception of extension_constructor * expression
   | Texp_assert of expression
   | Texp_lazy of expression
   | Texp_object of class_structure * string list
@@ -222,6 +237,10 @@ and case =
      c_rhs: expression;
     }
 
+and record_label_definition =
+  | Kept of Types.type_expr
+  | Overridden of Longident.t loc * expression
+
 (* Value expressions for the class language *)
 
 and class_expr =
@@ -613,7 +632,7 @@ and 'a class_infos =
     ci_id_class: Ident.t;
     ci_id_class_type : Ident.t;
     ci_id_object : Ident.t;
-    ci_id_typesharp : Ident.t;
+    ci_id_typehash : Ident.t;
     ci_expr: 'a;
     ci_decl: Types.class_declaration;
     ci_type_decl : Types.class_type_declaration;
diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml
index 39f0f6c7..86b96531 100644
--- a/typing/typedtreeIter.ml
+++ b/typing/typedtreeIter.ml
@@ -150,7 +150,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
             List.iter (fun (ci, _) -> iter_class_declaration ci) list
         | Tstr_class_type list ->
             List.iter
-              (fun (id, _, ct) -> iter_class_type_declaration ct)
+              (fun (_, _, ct) -> iter_class_type_declaration ct)
               list
         | Tstr_include incl -> iter_module_expr incl.incl_mod
         | Tstr_attribute _ ->
@@ -174,13 +174,13 @@ module MakeIterator(Iter : IteratorArgument) : sig
       iter_constructor_arguments cd.cd_args;
       option iter_core_type cd.cd_res;
 
-    and iter_type_parameter (ct, v) =
+    and iter_type_parameter (ct, _v) =
       iter_core_type ct
 
     and iter_type_declaration decl =
       Iter.enter_type_declaration decl;
       List.iter iter_type_parameter decl.typ_params;
-      List.iter (fun (ct1, ct2, loc) ->
+      List.iter (fun (ct1, ct2, _loc) ->
           iter_core_type ct1;
           iter_core_type ct2
       ) decl.typ_cstrs;
@@ -224,23 +224,24 @@ module MakeIterator(Iter : IteratorArgument) : sig
       List.iter (fun (cstr, _, _attrs) -> match cstr with
               | Tpat_type _ -> ()
               | Tpat_unpack -> ()
+              | Tpat_open _ -> ()
               | Tpat_constraint ct -> iter_core_type ct) pat.pat_extra;
       begin
         match pat.pat_desc with
           Tpat_any -> ()
-        | Tpat_var (id, _) -> ()
+        | Tpat_var _ -> ()
         | Tpat_alias (pat1, _, _) -> iter_pattern pat1
-        | Tpat_constant cst -> ()
+        | Tpat_constant _ -> ()
         | Tpat_tuple list ->
             List.iter iter_pattern list
         | Tpat_construct (_, _, args) ->
             List.iter iter_pattern args
-        | Tpat_variant (label, pato, _) ->
+        | Tpat_variant (_, pato, _) ->
             begin match pato with
                 None -> ()
               | Some pat -> iter_pattern pat
             end
-        | Tpat_record (list, closed) ->
+        | Tpat_record (list, _closed) ->
             List.iter (fun (_, _, pat) -> iter_pattern pat) list
         | Tpat_array list -> List.iter iter_pattern list
         | Tpat_or (p1, p2, _) -> iter_pattern p1; iter_pattern p2
@@ -258,22 +259,22 @@ module MakeIterator(Iter : IteratorArgument) : sig
             iter_core_type ct
         | Texp_coerce (cty1, cty2) ->
             option iter_core_type cty1; iter_core_type cty2
-        | Texp_open (_, path, _, _) -> ()
+        | Texp_open _ -> ()
         | Texp_poly cto -> option iter_core_type cto
-        | Texp_newtype s -> ())
+        | Texp_newtype _ -> ())
         exp.exp_extra;
       begin
         match exp.exp_desc with
-          Texp_ident (path, _, _) -> ()
-        | Texp_constant cst -> ()
+          Texp_ident _ -> ()
+        | Texp_constant _ -> ()
         | Texp_let (rec_flag, list, exp) ->
             iter_bindings rec_flag list;
             iter_expression exp
-        | Texp_function (label, cases, _) ->
+        | Texp_function (_label, cases, _) ->
             iter_cases cases
         | Texp_apply (exp, list) ->
             iter_expression exp;
-            List.iter (fun (label, expo) ->
+            List.iter (fun (_label, expo) ->
                 match expo with
                   None -> ()
                 | Some exp -> iter_expression exp
@@ -289,20 +290,23 @@ module MakeIterator(Iter : IteratorArgument) : sig
             List.iter iter_expression list
         | Texp_construct (_, _, args) ->
             List.iter iter_expression args
-        | Texp_variant (label, expo) ->
+        | Texp_variant (_label, expo) ->
             begin match expo with
                 None -> ()
               | Some exp -> iter_expression exp
             end
-        | Texp_record (list, expo) ->
-            List.iter (fun (_, _, exp) -> iter_expression exp) list;
-            begin match expo with
+        | Texp_record { fields; extended_expression; _ } ->
+            Array.iter (function
+                | _, Kept _ -> ()
+                | _, Overridden (_, exp) -> iter_expression exp)
+              fields;
+            begin match extended_expression with
                 None -> ()
               | Some exp -> iter_expression exp
             end
-        | Texp_field (exp, _, label) ->
+        | Texp_field (exp, _, _label) ->
             iter_expression exp
-        | Texp_setfield (exp1, _, label, exp2) ->
+        | Texp_setfield (exp1, _, _label, exp2) ->
             iter_expression exp1;
             iter_expression exp2
         | Texp_array list ->
@@ -320,28 +324,31 @@ module MakeIterator(Iter : IteratorArgument) : sig
         | Texp_while (exp1, exp2) ->
             iter_expression exp1;
             iter_expression exp2
-        | Texp_for (id, _, exp1, exp2, dir, exp3) ->
+        | Texp_for (_id, _, exp1, exp2, _dir, exp3) ->
             iter_expression exp1;
             iter_expression exp2;
             iter_expression exp3
-        | Texp_send (exp, meth, expo) ->
+        | Texp_send (exp, _meth, expo) ->
             iter_expression exp;
           begin
             match expo with
                 None -> ()
               | Some exp -> iter_expression exp
           end
-        | Texp_new (path, _, _) -> ()
-        | Texp_instvar (_, path, _) -> ()
+        | Texp_new _ -> ()
+        | Texp_instvar _ -> ()
         | Texp_setinstvar (_, _, _, exp) ->
             iter_expression exp
         | Texp_override (_, list) ->
-            List.iter (fun (path, _, exp) ->
+            List.iter (fun (_path, _, exp) ->
                 iter_expression exp
             ) list
-        | Texp_letmodule (id, _, mexpr, exp) ->
+        | Texp_letmodule (_id, _, mexpr, exp) ->
             iter_module_expr mexpr;
             iter_expression exp
+        | Texp_letexception (cd, exp) ->
+            iter_extension_constructor cd;
+            iter_expression exp
         | Texp_assert exp -> iter_expression exp
         | Texp_lazy exp -> iter_expression exp
         | Texp_object (cl, _) ->
@@ -357,7 +364,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
 
     and iter_package_type pack =
       Iter.enter_package_type pack;
-      List.iter (fun (s, ct) -> iter_core_type ct) pack.pack_fields;
+      List.iter (fun (_s, ct) -> iter_core_type ct) pack.pack_fields;
       Iter.leave_package_type pack;
 
     and iter_signature sg =
@@ -424,14 +431,14 @@ module MakeIterator(Iter : IteratorArgument) : sig
       Iter.enter_module_type mty;
       begin
         match mty.mty_desc with
-          Tmty_ident (path, _) -> ()
-        | Tmty_alias (path, _) -> ()
+          Tmty_ident _ -> ()
+        | Tmty_alias _ -> ()
         | Tmty_signature sg -> iter_signature sg
-        | Tmty_functor (id, _, mtype1, mtype2) ->
+        | Tmty_functor (_, _, mtype1, mtype2) ->
             Misc.may iter_module_type mtype1; iter_module_type mtype2
         | Tmty_with (mtype, list) ->
             iter_module_type mtype;
-            List.iter (fun (path, _, withc) ->
+            List.iter (fun (_path, _, withc) ->
                 iter_with_constraint withc
             ) list
         | Tmty_typeof mexpr ->
@@ -454,9 +461,9 @@ module MakeIterator(Iter : IteratorArgument) : sig
       Iter.enter_module_expr mexpr;
       begin
         match mexpr.mod_desc with
-          Tmod_ident (p, _) -> ()
+          Tmod_ident _ -> ()
         | Tmod_structure st -> iter_structure st
-        | Tmod_functor (id, _, mtype, mexpr) ->
+        | Tmod_functor (_, _, mtype, mexpr) ->
             Misc.may iter_module_type mtype;
             iter_module_expr mexpr
         | Tmod_apply (mexp1, mexp2, _) ->
@@ -467,7 +474,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
         | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) ->
             iter_module_expr mexpr;
             iter_module_type mtype
-        | Tmod_unpack (exp, mty) ->
+        | Tmod_unpack (exp, _mty) ->
             iter_expression exp
 (*          iter_module_type mty *)
       end;
@@ -480,14 +487,14 @@ module MakeIterator(Iter : IteratorArgument) : sig
         | Tcl_constraint (cl, None, _, _, _ ) ->
             iter_class_expr cl;
         | Tcl_structure clstr -> iter_class_structure clstr
-        | Tcl_fun (label, pat, priv, cl, partial) ->
+        | Tcl_fun (_label, pat, priv, cl, _partial) ->
           iter_pattern pat;
-          List.iter (fun (id, _, exp) -> iter_expression exp) priv;
+          List.iter (fun (_id, _, exp) -> iter_expression exp) priv;
           iter_class_expr cl
 
         | Tcl_apply (cl, args) ->
             iter_class_expr cl;
-            List.iter (fun (label, expo) ->
+            List.iter (fun (_label, expo) ->
                 match expo with
                   None -> ()
                 | Some exp -> iter_expression exp
@@ -495,10 +502,10 @@ module MakeIterator(Iter : IteratorArgument) : sig
 
         | Tcl_let (rec_flat, bindings, ivars, cl) ->
           iter_bindings rec_flat bindings;
-          List.iter (fun (id, _, exp) -> iter_expression exp) ivars;
+          List.iter (fun (_id, _, exp) -> iter_expression exp) ivars;
             iter_class_expr cl
 
-        | Tcl_constraint (cl, Some clty, vals, meths, concrs) ->
+        | Tcl_constraint (cl, Some clty, _vals, _meths, _concrs) ->
             iter_class_expr cl;
             iter_class_type clty
 
@@ -512,9 +519,9 @@ module MakeIterator(Iter : IteratorArgument) : sig
       begin
         match ct.cltyp_desc with
           Tcty_signature csg -> iter_class_signature csg
-        | Tcty_constr (path, _, list) ->
+        | Tcty_constr (_path, _, list) ->
             List.iter iter_core_type list
-        | Tcty_arrow (label, ct, cl) ->
+        | Tcty_arrow (_label, ct, cl) ->
             iter_core_type ct;
             iter_class_type cl
       end;
@@ -532,9 +539,9 @@ module MakeIterator(Iter : IteratorArgument) : sig
       begin
         match ctf.ctf_desc with
           Tctf_inherit ct -> iter_class_type ct
-        | Tctf_val (s, _mut, _virt, ct) ->
+        | Tctf_val (_s, _mut, _virt, ct) ->
             iter_core_type ct
-        | Tctf_method (s, _priv, _virt, ct) ->
+        | Tctf_method (_s, _priv, _virt, ct) ->
             iter_core_type ct
         | Tctf_constraint  (ct1, ct2) ->
             iter_core_type ct1;
@@ -548,22 +555,22 @@ module MakeIterator(Iter : IteratorArgument) : sig
       begin
         match ct.ctyp_desc with
           Ttyp_any -> ()
-        | Ttyp_var s -> ()
-        | Ttyp_arrow (label, ct1, ct2) ->
+        | Ttyp_var _ -> ()
+        | Ttyp_arrow (_label, ct1, ct2) ->
             iter_core_type ct1;
             iter_core_type ct2
         | Ttyp_tuple list -> List.iter iter_core_type list
-        | Ttyp_constr (path, _, list) ->
+        | Ttyp_constr (_path, _, list) ->
             List.iter iter_core_type list
-        | Ttyp_object (list, o) ->
+        | Ttyp_object (list, _o) ->
             List.iter (fun (_, _, t) -> iter_core_type t) list
-        | Ttyp_class (path, _, list) ->
+        | Ttyp_class (_path, _, list) ->
             List.iter iter_core_type list
-        | Ttyp_alias (ct, s) ->
+        | Ttyp_alias (ct, _s) ->
             iter_core_type ct
-        | Ttyp_variant (list, bool, labels) ->
+        | Ttyp_variant (list, _bool, _labels) ->
             List.iter iter_row_field list
-        | Ttyp_poly (list, ct) -> iter_core_type ct
+        | Ttyp_poly (_list, ct) -> iter_core_type ct
         | Ttyp_package pack -> iter_package_type pack
       end;
       Iter.leave_core_type ct
@@ -577,7 +584,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
 
     and iter_row_field rf =
       match rf with
-        Ttag (label, _attrs, bool, list) ->
+        Ttag (_label, _attrs, _bool, list) ->
           List.iter iter_core_type list
       | Tinherit ct -> iter_core_type ct
 
@@ -585,18 +592,18 @@ module MakeIterator(Iter : IteratorArgument) : sig
       Iter.enter_class_field cf;
       begin
         match cf.cf_desc with
-          Tcf_inherit (ovf, cl, super, _vals, _meths) ->
+          Tcf_inherit (_ovf, cl, _super, _vals, _meths) ->
           iter_class_expr cl
       | Tcf_constraint (cty, cty') ->
           iter_core_type cty;
           iter_core_type cty'
-      | Tcf_val (lab, _, _, Tcfk_virtual cty, _) ->
+      | Tcf_val (_lab, _, _, Tcfk_virtual cty, _) ->
           iter_core_type cty
-      | Tcf_val (lab, _, _, Tcfk_concrete (_, exp), _) ->
+      | Tcf_val (_lab, _, _, Tcfk_concrete (_, exp), _) ->
           iter_expression exp
-      | Tcf_method (lab, _, Tcfk_virtual cty) ->
+      | Tcf_method (_lab, _, Tcfk_virtual cty) ->
           iter_core_type cty
-      | Tcf_method (lab, _, Tcfk_concrete (_, exp)) ->
+      | Tcf_method (_lab, _, Tcfk_concrete (_, exp)) ->
           iter_expression exp
       | Tcf_initializer exp ->
           iter_expression exp
diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml
index 46077aa3..0695b2fe 100644
--- a/typing/typedtreeMap.ml
+++ b/typing/typedtreeMap.ml
@@ -94,7 +94,7 @@ module MakeMap(Map : MapArgument) = struct
       vb_loc = vb.vb_loc;
     }
 
-  and map_bindings rec_flag list =
+  and map_bindings list =
     List.map map_binding list
 
   and map_case {c_lhs; c_guard; c_rhs} =
@@ -113,7 +113,7 @@ module MakeMap(Map : MapArgument) = struct
       match item.str_desc with
           Tstr_eval (exp, attrs) -> Tstr_eval (map_expression exp, attrs)
         | Tstr_value (rec_flag, list) ->
-          Tstr_value (rec_flag, map_bindings rec_flag list)
+          Tstr_value (rec_flag, map_bindings list)
         | Tstr_primitive vd ->
           Tstr_primitive (map_value_description vd)
         | Tstr_type (rf, list) ->
@@ -259,7 +259,7 @@ module MakeMap(Map : MapArgument) = struct
     match pat_extra with
       | Tpat_constraint ct, loc, attrs ->
           (Tpat_constraint (map_core_type  ct), loc, attrs)
-      | (Tpat_type _ | Tpat_unpack), _, _ -> pat_extra
+      | (Tpat_type _ | Tpat_unpack | Tpat_open _ ), _, _ -> pat_extra
 
   and map_expression exp =
     let exp = Map.enter_expression exp in
@@ -269,7 +269,7 @@ module MakeMap(Map : MapArgument) = struct
         | Texp_constant _ -> exp.exp_desc
         | Texp_let (rec_flag, list, exp) ->
           Texp_let (rec_flag,
-                    map_bindings rec_flag list,
+                    map_bindings list,
                     map_expression exp)
         | Texp_function (label, cases, partial) ->
           Texp_function (label, map_cases cases, partial)
@@ -306,16 +306,19 @@ module MakeMap(Map : MapArgument) = struct
             | Some exp -> Some (map_expression exp)
           in
           Texp_variant (label, expo)
-        | Texp_record (list, expo) ->
-          let list =
-            List.map (fun (lid, lab_desc, exp) ->
-              (lid, lab_desc, map_expression exp)
-            ) list in
-          let expo = match expo with
-              None -> expo
+        | Texp_record { fields; representation; extended_expression } ->
+          let fields =
+            Array.map (function
+                | label, Kept t -> label, Kept t
+                | label, Overridden (lid, exp) ->
+                    label, Overridden (lid, map_expression exp))
+              fields
+          in
+          let extended_expression = match extended_expression with
+              None -> extended_expression
             | Some exp -> Some (map_expression exp)
           in
-          Texp_record (list, expo)
+          Texp_record { fields; representation; extended_expression }
         | Texp_field (exp, lid, label) ->
           Texp_field (map_expression exp, lid, label)
         | Texp_setfield (exp1, lid, label, exp2) ->
@@ -354,8 +357,8 @@ module MakeMap(Map : MapArgument) = struct
           )
         | Texp_send (exp, meth, expo) ->
           Texp_send (map_expression exp, meth, may_map map_expression expo)
-        | Texp_new (path, lid, cl_decl) -> exp.exp_desc
-        | Texp_instvar (_, path, _) -> exp.exp_desc
+        | Texp_new _ -> exp.exp_desc
+        | Texp_instvar _ -> exp.exp_desc
         | Texp_setinstvar (path, lid, path2, exp) ->
           Texp_setinstvar (path, lid, path2, map_expression exp)
         | Texp_override (path, list) ->
@@ -371,6 +374,11 @@ module MakeMap(Map : MapArgument) = struct
             map_module_expr mexpr,
             map_expression exp
           )
+        | Texp_letexception (cd, exp) ->
+          Texp_letexception (
+            map_extension_constructor cd,
+            map_expression exp
+          )
         | Texp_assert exp -> Texp_assert (map_expression exp)
         | Texp_lazy exp -> Texp_lazy (map_expression exp)
         | Texp_object (cl, string_list) ->
@@ -499,8 +507,8 @@ module MakeMap(Map : MapArgument) = struct
       match cstr with
           Twith_type decl -> Twith_type (map_type_declaration decl)
         | Twith_typesubst decl -> Twith_typesubst (map_type_declaration decl)
-        | Twith_module (path, lid) -> cstr
-        | Twith_modsubst (path, lid) -> cstr
+        | Twith_module _ -> cstr
+        | Twith_modsubst _ -> cstr
     in
     Map.leave_with_constraint cstr
 
@@ -508,7 +516,7 @@ module MakeMap(Map : MapArgument) = struct
     let mexpr = Map.enter_module_expr mexpr in
     let mod_desc =
       match mexpr.mod_desc with
-          Tmod_ident (p, lid) -> mexpr.mod_desc
+          Tmod_ident _ -> mexpr.mod_desc
         | Tmod_structure st -> Tmod_structure (map_structure st)
         | Tmod_functor (id, name, mtype, mexpr) ->
           Tmod_functor (id, name, Misc.may_map map_module_type mtype,
@@ -547,8 +555,8 @@ module MakeMap(Map : MapArgument) = struct
                      List.map (fun (label, expo) ->
                        (label, may_map map_expression expo)
                      ) args)
-        | Tcl_let (rec_flat, bindings, ivars, cl) ->
-          Tcl_let (rec_flat, map_bindings rec_flat bindings,
+        | Tcl_let (rec_flag, bindings, ivars, cl) ->
+          Tcl_let (rec_flag, map_bindings bindings,
                    List.map (fun (id, name, exp) ->
                      (id, name, map_expression exp)) ivars,
                    map_class_expr cl)
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 1ea9bea8..0aa95e5d 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -47,6 +47,13 @@ type error =
 exception Error of Location.t * Env.t * error
 exception Error_forward of Location.error
 
+module ImplementationHooks = Misc.MakeHooks(struct
+    type t = Typedtree.structure * Typedtree.module_coercion
+  end)
+module InterfaceHooks = Misc.MakeHooks(struct
+    type t = Typedtree.signature
+  end)
+
 open Typedtree
 
 let fst3 (x,_,_) = x
@@ -62,14 +69,14 @@ let rec path_concat head p =
 let extract_sig env loc mty =
   match Env.scrape_alias env mty with
     Mty_signature sg -> sg
-  | Mty_alias path ->
+  | Mty_alias(_, path) ->
       raise(Error(loc, env, Cannot_scrape_alias path))
   | _ -> raise(Error(loc, env, Signature_expected))
 
 let extract_sig_open env loc mty =
   match Env.scrape_alias env mty with
     Mty_signature sg -> sg
-  | Mty_alias path ->
+  | Mty_alias(_, path) ->
       raise(Error(loc, env, Cannot_scrape_alias path))
   | _ -> raise(Error(loc, env, Structure_expected mty))
 
@@ -104,7 +111,7 @@ let rm node =
 let type_module_type_of_fwd :
     (Env.t -> Parsetree.module_expr ->
       Typedtree.module_expr * Types.module_type) ref
-  = ref (fun env m -> assert false)
+  = ref (fun _env _m -> assert false)
 
 (* Merge one "with" constraint in a signature *)
 
@@ -139,10 +146,6 @@ let make p n i =
   let open Variance in
   set May_pos p (set May_neg n (set May_weak n (set Inj i null)))
 
-let ensure_functor_arg p env =
-  if Env.is_functor_arg p env then env else
-  Env.add_functor_arg (Path.head p) env
-
 let merge_constraint initial_env loc sg constr =
   let lid =
     match constr with
@@ -181,6 +184,7 @@ let merge_constraint initial_env loc sg constr =
             type_newtype_level = None;
             type_attributes = [];
             type_immediate = false;
+            type_unboxed = unboxed_false_default_false;
           }
         and id_row = Ident.create (s^"#row") in
         let initial_env =
@@ -201,7 +205,7 @@ let merge_constraint initial_env loc sg constr =
         let newdecl = tdecl.typ_type in
         check_type_decl env sdecl.ptype_loc id row_id newdecl decl rs rem;
         (Pident id, lid, Twith_type tdecl), Sig_type(id, newdecl, rs) :: rem
-    | (Sig_type(id, decl, rs) :: rem, [s], (Pwith_type _ | Pwith_typesubst _))
+    | (Sig_type(id, _, _) :: rem, [s], (Pwith_type _ | Pwith_typesubst _))
       when Ident.name id = s ^ "#row" ->
         merge env rem namelist (Some id)
     | (Sig_type(id, decl, rs) :: rem, [s], Pwith_typesubst sdecl)
@@ -218,23 +222,21 @@ let merge_constraint initial_env loc sg constr =
       when Ident.name id = s ->
         let path, md' = Typetexp.find_module initial_env loc lid'.txt in
         let md'' = {md' with md_type = Mtype.remove_aliases env md'.md_type} in
-        let env = ensure_functor_arg path env in
-        let newmd = Mtype.strengthen_decl env md'' path in
+        let newmd = Mtype.strengthen_decl ~aliasable:false env md'' path in
         ignore(Includemod.modtypes env newmd.md_type md.md_type);
         (Pident id, lid, Twith_module (path, lid')),
         Sig_module(id, newmd, rs) :: rem
     | (Sig_module(id, md, rs) :: rem, [s], Pwith_modsubst (_, lid'))
       when Ident.name id = s ->
         let path, md' = Typetexp.find_module initial_env loc lid'.txt in
-        let env = ensure_functor_arg path env in
-        let newmd = Mtype.strengthen_decl env md' path in
+        let newmd = Mtype.strengthen_decl ~aliasable:false env md' path in
         ignore(Includemod.modtypes env newmd.md_type md.md_type);
         real_id := Some id;
         (Pident id, lid, Twith_modsubst (path, lid')),
         update_rec_next rs rem
     | (Sig_module(id, md, rs) :: rem, s :: namelist, _)
       when Ident.name id = s ->
-        let ((path, path_loc, tcstr), newsg) =
+        let ((path, _path_loc, tcstr), newsg) =
           merge env (extract_sig env loc md.md_type) namelist None in
         (path_concat id path, lid, tcstr),
         Sig_module(id, {md with md_type=Mty_signature newsg}, rs) :: rem
@@ -248,7 +250,7 @@ let merge_constraint initial_env loc sg constr =
     let (tcstr, sg) = merge initial_env sg names None in
     let sg =
     match names, constr with
-      [s], Pwith_typesubst sdecl ->
+      [_], Pwith_typesubst sdecl ->
         let id =
           match !real_id with None -> assert false | Some id -> id in
         let lid =
@@ -266,12 +268,12 @@ let merge_constraint initial_env loc sg constr =
           with Exit ->
             raise(Error(sdecl.ptype_loc, initial_env, With_need_typeconstr))
         in
-        let (path, _) =
+        let path =
           try Env.lookup_type lid.txt initial_env with Not_found -> assert false
         in
         let sub = Subst.add_type id path Subst.identity in
         Subst.signature sub sg
-    | [s], Pwith_modsubst (_, lid) ->
+    | [_], Pwith_modsubst (_, lid) ->
         let id =
           match !real_id with None -> assert false | Some id -> id in
         let path = Typetexp.lookup_module initial_env loc lid.txt in
@@ -327,11 +329,11 @@ let map_ext fn exts rem =
 let rec approx_modtype env smty =
   match smty.pmty_desc with
     Pmty_ident lid ->
-      let (path, info) = Typetexp.find_modtype env smty.pmty_loc lid.txt in
+      let (path, _info) = Typetexp.find_modtype env smty.pmty_loc lid.txt in
       Mty_ident path
   | Pmty_alias lid ->
       let path = Typetexp.lookup_module env smty.pmty_loc lid.txt in
-      Mty_alias path
+      Mty_alias(Mta_absent, path)
   | Pmty_signature ssg ->
       Mty_signature(approx_sig env ssg)
   | Pmty_functor(param, sarg, sres) ->
@@ -340,7 +342,7 @@ let rec approx_modtype env smty =
         Env.enter_module ~arg:true param.txt (Btype.default_mty arg) env in
       let res = approx_modtype newenv sres in
       Mty_functor(id, arg, res)
-  | Pmty_with(sbody, constraints) ->
+  | Pmty_with(sbody, _constraints) ->
       approx_modtype env sbody
   | Pmty_typeof smod ->
       let (_, mty) = !type_module_type_of_fwd env smod in
@@ -361,7 +363,7 @@ and approx_sig env ssg =
   | item :: srem ->
       match item.psig_desc with
       | Psig_type (rec_flag, sdecls) ->
-          let decls = Typedecl.approx_type_decl env sdecls in
+          let decls = Typedecl.approx_type_decl sdecls in
           let rem = approx_sig env srem in
           map_rec_type ~rec_flag
             (fun rs (id, info) -> Sig_type(id, info, rs)) decls rem
@@ -381,7 +383,8 @@ and approx_sig env ssg =
           in
           let newenv =
             List.fold_left
-              (fun env (id, md) -> Env.add_module_declaration id md env)
+              (fun env (id, md) -> Env.add_module_declaration ~check:false
+                  id md env)
               env decls in
           map_rec (fun rs (id, md) -> Sig_module(id, md, rs)) decls
                   (approx_sig newenv srem)
@@ -390,7 +393,7 @@ and approx_sig env ssg =
           let (id, newenv) = Env.enter_modtype d.pmtd_name.txt info env in
           Sig_modtype(id, info) :: approx_sig newenv srem
       | Psig_open sod ->
-          let (path, mty, _od) = type_open env sod in
+          let (_path, mty, _od) = type_open env sod in
           approx_sig mty srem
       | Psig_include sincl ->
           let smty = sincl.pincl_mod in
@@ -404,10 +407,11 @@ and approx_sig env ssg =
           let rem = approx_sig env srem in
           List.flatten
             (map_rec
-              (fun rs (i1, _, d1, i2, d2, i3, d3, _) ->
-                [Sig_class_type(i1, d1, rs);
-                 Sig_type(i2, d2, rs);
-                 Sig_type(i3, d3, rs)])
+               (fun rs decl ->
+                  let open Typeclass in
+                  [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs);
+                   Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs);
+                   Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs)])
               decls [rem])
       | _ ->
           approx_sig env srem
@@ -437,7 +441,7 @@ let check_recmod_typedecls env sdecls decls =
 (* Auxiliaries for checking uniqueness of names in signatures and structures *)
 
 module StringSet =
-  Set.Make(struct type t = string let compare (x:t) y = compare x y end)
+  Set.Make(struct type t = string let compare (x:t) y = String.compare x y end)
 
 let check cl loc set_ref name =
   if StringSet.mem name !set_ref
@@ -483,7 +487,7 @@ let check_sig_item names loc = function
 let simplify_signature sg =
   let rec aux = function
     | [] -> [], StringSet.empty
-    | (Sig_value(id, descr) as component) :: sg ->
+    | (Sig_value(id, _descr) as component) :: sg ->
         let (sg, val_names) as k = aux sg in
         let name = Ident.name id in
         if StringSet.mem name val_names then k
@@ -498,7 +502,7 @@ let simplify_signature sg =
 (* Check and translate a module type expression *)
 
 let transl_modtype_longident loc env lid =
-  let (path, info) = Typetexp.find_modtype env loc lid in
+  let (path, _info) = Typetexp.find_modtype env loc lid in
   path
 
 let transl_module_alias loc env lid =
@@ -531,7 +535,7 @@ let rec transl_modtype env smty =
         smty.pmty_attributes
   | Pmty_alias lid ->
       let path = transl_module_alias loc env lid.txt in
-      mkmty (Tmty_alias (path, lid)) (Mty_alias path) env loc
+      mkmty (Tmty_alias (path, lid)) (Mty_alias(Mta_absent, path)) env loc
         smty.pmty_attributes
   | Pmty_signature ssg ->
       let sg = transl_signature env ssg in
@@ -644,7 +648,7 @@ and transl_signature env sg =
               (fun pmd -> check_name check_module names pmd.pmd_name)
               sdecls;
             let (decls, newenv) =
-              transl_recmodule_modtypes item.psig_loc env sdecls in
+              transl_recmodule_modtypes env sdecls in
             let (trem, rem, final_env) = transl_sig newenv srem in
             mksig (Tsig_recmodule decls) env loc :: trem,
             map_rec (fun rs md ->
@@ -658,14 +662,14 @@ and transl_signature env sg =
         | Psig_modtype pmtd ->
             let newenv, mtd, sg =
               Builtin_attributes.with_warning_attribute pmtd.pmtd_attributes
-                (fun () -> transl_modtype_decl names env item.psig_loc pmtd)
+                (fun () -> transl_modtype_decl names env pmtd)
             in
             let (trem, rem, final_env) = transl_sig newenv srem in
             mksig (Tsig_modtype mtd) env loc :: trem,
             sg :: rem,
             final_env
         | Psig_open sod ->
-            let (path, newenv, od) = type_open env sod in
+            let (_path, newenv, od) = type_open env sod in
             let (trem, rem, final_env) = transl_sig newenv srem in
             mksig (Tsig_open od) env loc :: trem,
             rem, final_env
@@ -698,19 +702,17 @@ and transl_signature env sg =
             let (classes, newenv) = Typeclass.class_descriptions env cl in
             let (trem, rem, final_env) = transl_sig newenv srem in
             mksig (Tsig_class
-                     (List.map2
-                        (fun pcl tcl ->
-                          let (_, _, _, _, _, _, _, _, _, _, _, tcl) = tcl in
-                          tcl)
-                        cl classes)) env loc
+                     (List.map (fun decr ->
+                          decr.Typeclass.cls_info) classes)) env loc
             :: trem,
             List.flatten
               (map_rec
-                 (fun rs (i, _, d, i', d', i'', d'', i''', d''', _, _, _) ->
-                   [Sig_class(i, d, rs);
-                    Sig_class_type(i', d', rs);
-                    Sig_type(i'', d'', rs);
-                    Sig_type(i''', d''', rs)])
+                 (fun rs cls ->
+                    let open Typeclass in
+                    [Sig_class(cls.cls_id, cls.cls_decl, rs);
+                     Sig_class_type(cls.cls_ty_id, cls.cls_ty_decl, rs);
+                     Sig_type(cls.cls_obj_id, cls.cls_obj_abbr, rs);
+                     Sig_type(cls.cls_typesharp_id, cls.cls_abbr, rs)])
                  classes [rem]),
             final_env
         | Psig_class_type cl ->
@@ -719,16 +721,16 @@ and transl_signature env sg =
               cl;
             let (classes, newenv) = Typeclass.class_type_declarations env cl in
             let (trem,rem, final_env) = transl_sig newenv srem in
-            mksig (Tsig_class_type (List.map2 (fun pcl tcl ->
-              let (_, _, _, _, _, _, _, tcl) = tcl in
-              tcl
-            ) cl classes)) env loc :: trem,
+            mksig (Tsig_class_type
+                     (List.map (fun decl -> decl.Typeclass.clsty_info) classes))
+              env loc :: trem,
             List.flatten
               (map_rec
-                 (fun rs (i, _, d, i', d', i'', d'', _) ->
-                   [Sig_class_type(i, d, rs);
-                    Sig_type(i', d', rs);
-                    Sig_type(i'', d'', rs)])
+                 (fun rs decl ->
+                    let open Typeclass in
+                    [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs);
+                     Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs);
+                     Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs)])
                  classes [rem]),
             final_env
         | Psig_attribute x ->
@@ -748,7 +750,7 @@ and transl_signature env sg =
     ((Cmt_format.Partial_signature sg) :: previous_saved_types);
   sg
 
-and transl_modtype_decl names env loc
+and transl_modtype_decl names env
     {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} =
   check_name check_modtype names pmtd_name;
   let tmty = Misc.may_map (transl_modtype env) pmtd_type in
@@ -771,7 +773,7 @@ and transl_modtype_decl names env loc
   in
   newenv, mtd, Sig_modtype(id, decl)
 
-and transl_recmodule_modtypes loc env sdecls =
+and transl_recmodule_modtypes env sdecls =
   let make_env curr =
     List.fold_left
       (fun env (id, _, mty) -> Env.add_module ~arg:true id mty env)
@@ -782,7 +784,7 @@ and transl_recmodule_modtypes loc env sdecls =
       env curr in
   let transition env_c curr =
     List.map2
-      (fun pmd (id, id_loc, mty) ->
+      (fun pmd (id, id_loc, _mty) ->
         let tmty =
           Builtin_attributes.with_warning_attribute pmd.pmd_attributes
             (fun () -> transl_modtype env_c pmd.pmd_type)
@@ -841,7 +843,7 @@ exception Not_a_path
 let rec path_of_module mexp =
   match mexp.mod_desc with
     Tmod_ident (p,_) -> p
-  | Tmod_apply(funct, arg, coercion) when !Clflags.applicative_functors ->
+  | Tmod_apply(funct, arg, _coercion) when !Clflags.applicative_functors ->
       Papply(path_of_module funct, path_of_module arg)
   | Tmod_constraint (mexp, _, _, _) ->
       path_of_module mexp
@@ -853,8 +855,8 @@ let path_of_module mexp =
 (* Check that all core type schemes in a structure are closed *)
 
 let rec closed_modtype env = function
-    Mty_ident p -> true
-  | Mty_alias p -> true
+    Mty_ident _ -> true
+  | Mty_alias _ -> true
   | Mty_signature sg ->
       let env = Env.add_signature sg env in
       List.for_all (closed_signature_item env) sg
@@ -863,8 +865,8 @@ let rec closed_modtype env = function
       closed_modtype env body
 
 and closed_signature_item env = function
-    Sig_value(id, desc) -> Ctype.closed_schema env desc.val_type
-  | Sig_module(id, md, _) -> closed_modtype env md.md_type
+    Sig_value(_id, desc) -> Ctype.closed_schema env desc.val_type
+  | Sig_module(_id, md, _) -> closed_modtype env md.md_type
   | _ -> true
 
 let check_nongen_scheme env sig_item =
@@ -884,7 +886,7 @@ let check_nongen_schemes env sg =
 
 let anchor_submodule name anchor =
   match anchor with None -> None | Some p -> Some(Pdot(p, name, nopos))
-let anchor_recmodule id anchor =
+let anchor_recmodule id =
   Some (Pident id)
 
 let enrich_type_decls anchor decls oldenv newenv =
@@ -928,17 +930,15 @@ let check_recmodule_inclusion env bindings =
      the number of mutually recursive declarations. *)
 
   let subst_and_strengthen env s id mty =
-    let p = Subst.module_path s (Pident id) in
-    let env = ensure_functor_arg p env in
-    Mtype.strengthen env (Subst.modtype s mty) p
-  in
+    Mtype.strengthen ~aliasable:false env (Subst.modtype s mty)
+      (Subst.module_path s (Pident id)) in
 
   let rec check_incl first_time n env s =
     if n > 0 then begin
       (* Generate fresh names Y_i for the rec. bound module idents X_i *)
       let bindings1 =
         List.map
-          (fun (id, _, mty_decl, modl, mty_actual, _attrs, _loc) ->
+          (fun (id, _, _mty_decl, _modl, mty_actual, _attrs, _loc) ->
              (id, Ident.rename id, mty_actual))
           bindings in
       (* Enter the Y_i in the environment with their actual types substituted
@@ -955,7 +955,7 @@ let check_recmodule_inclusion env bindings =
       (* Build the output substitution Y_i <- X_i *)
       let s' =
         List.fold_left
-          (fun s (id, id', mty_actual) ->
+          (fun s (id, id', _mty_actual) ->
              Subst.add_module id (Pident id') s)
           Subst.identity bindings1 in
       (* Recurse with env' and s' *)
@@ -1037,14 +1037,14 @@ let modtype_of_package env loc p nl tl =
 let package_subtype env p1 nl1 tl1 p2 nl2 tl2 =
   let mkmty p nl tl =
     let ntl =
-      List.filter (fun (n,t) -> Ctype.free_variables t = [])
+      List.filter (fun (_n,t) -> Ctype.free_variables t = [])
         (List.combine nl tl) in
     let (nl, tl) = List.split ntl in
     modtype_of_package env Location.none p nl tl
   in
   let mty1 = mkmty p1 nl1 tl1 and mty2 = mkmty p2 nl2 tl2 in
   try Includemod.modtypes env mty1 mty2 = Tcoerce_none
-  with Includemod.Error msg -> false
+  with Includemod.Error _msg -> false
     (* raise(Error(Location.none, env, Not_included msg)) *)
 
 let () = Ctype.package_subtype := package_subtype
@@ -1069,28 +1069,33 @@ let rec type_module ?(alias=false) sttn funct_body anchor env smod =
       let path =
         Typetexp.lookup_module ~load:(not alias) env smod.pmod_loc lid.txt in
       let md = { mod_desc = Tmod_ident (path, lid);
-                 mod_type = Mty_alias path;
+                 mod_type = Mty_alias(Mta_absent, path);
                  mod_env = env;
                  mod_attributes = smod.pmod_attributes;
                  mod_loc = smod.pmod_loc } in
+      let aliasable = not (Env.is_functor_arg path env) in
       let md =
-        if alias && not (Env.is_functor_arg path env) then
+        if alias && aliasable then
           (Env.add_required_global (Path.head path); md)
         else match (Env.find_module path env).md_type with
-          Mty_alias p1 when not alias ->
+          Mty_alias(_, p1) when not alias ->
             let p1 = Env.normalize_path (Some smod.pmod_loc) env p1 in
             let mty = Includemod.expand_module_alias env [] p1 in
             { md with
               mod_desc = Tmod_constraint (md, mty, Tmodtype_implicit,
                                           Tcoerce_alias (p1, Tcoerce_none));
-              mod_type = if sttn then Mtype.strengthen env mty p1 else mty }
+              mod_type =
+                if sttn then Mtype.strengthen ~aliasable:true env mty p1
+                else mty }
         | mty ->
             let mty =
-              if sttn then Mtype.strengthen env mty path else mty in
+              if sttn then Mtype.strengthen ~aliasable env mty path
+              else mty
+            in
             { md with mod_type = mty }
       in rm md
   | Pmod_structure sstr ->
-      let (str, sg, finalenv) =
+      let (str, sg, _finalenv) =
         type_structure funct_body anchor env sstr smod.pmod_loc in
       let md =
         rm { mod_desc = Tmod_structure str;
@@ -1156,7 +1161,7 @@ let rec type_module ?(alias=false) sttn funct_body anchor env smod =
                mod_env = env;
                mod_attributes = smod.pmod_attributes;
                mod_loc = smod.pmod_loc }
-      | Mty_alias path ->
+      | Mty_alias(_, path) ->
           raise(Error(sfunct.pmod_loc, env, Cannot_scrape_alias path))
       | _ ->
           raise(Error(sfunct.pmod_loc, env, Cannot_apply funct.mod_type))
@@ -1316,8 +1321,8 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
           (fun (name, _, _, _, _) -> check_name check_module names name)
           sbind;
         let (decls, newenv) =
-          transl_recmodule_modtypes loc env
-            (List.map (fun (name, smty, smodl, attrs, loc) ->
+          transl_recmodule_modtypes env
+            (List.map (fun (name, smty, _smodl, attrs, loc) ->
                  {pmd_name=name; pmd_type=smty;
                   pmd_attributes=attrs; pmd_loc=loc}) sbind
             ) in
@@ -1327,7 +1332,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
                let modl =
                  Builtin_attributes.with_warning_attribute attrs
                    (fun () ->
-                      type_module true funct_body (anchor_recmodule id anchor)
+                      type_module true funct_body (anchor_recmodule id)
                         newenv smodl
                    )
                in
@@ -1346,7 +1351,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
                    md_loc = md.md_loc;
                  }
                in
-               Env.add_module_declaration md.md_id mdecl env
+               Env.add_module_declaration ~check:true md.md_id mdecl env
             )
             env decls
         in
@@ -1365,11 +1370,11 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
         (* check that it is non-abstract *)
         let newenv, mtd, sg =
           Builtin_attributes.with_warning_attribute pmtd.pmtd_attributes
-            (fun () -> transl_modtype_decl names env loc pmtd)
+            (fun () -> transl_modtype_decl names env pmtd)
         in
         Tstr_modtype mtd, [sg], newenv
     | Pstr_open sod ->
-        let (path, newenv, od) = type_open ~toplevel env sod in
+        let (_path, newenv, od) = type_open ~toplevel env sod in
         Tstr_open od, [], newenv
     | Pstr_class cl ->
         List.iter
@@ -1377,7 +1382,9 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
           cl;
         let (classes, new_env) = Typeclass.class_declarations env cl in
         Tstr_class
-          (List.map (fun (_,_,_,_,_,_,_,_,_,_, m, c) -> (c, m)) classes),
+          (List.map (fun cls ->
+               (cls.Typeclass.cls_info,
+                cls.Typeclass.cls_pub_methods)) classes),
 (* TODO: check with Jacques why this is here
       Tstr_class_type
           (List.map (fun (_,_, i, d, _,_,_,_,_,_,c) -> (i, c)) classes) ::
@@ -1388,11 +1395,12 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
 *)
         List.flatten
           (map_rec
-             (fun rs (i, _, d, i', d', i'', d'', i''', d''', _, _, _) ->
-                [Sig_class(i, d, rs);
-                 Sig_class_type(i', d', rs);
-                 Sig_type(i'', d'', rs);
-                 Sig_type(i''', d''', rs)])
+            (fun rs cls ->
+              let open Typeclass in
+              [Sig_class(cls.cls_id, cls.cls_decl, rs);
+               Sig_class_type(cls.cls_ty_id, cls.cls_ty_decl, rs);
+               Sig_type(cls.cls_obj_id, cls.cls_obj_abbr, rs);
+               Sig_type(cls.cls_typesharp_id, cls.cls_abbr, rs)])
              classes []),
         new_env
     | Pstr_class_type cl ->
@@ -1401,8 +1409,10 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
           cl;
         let (classes, new_env) = Typeclass.class_type_declarations env cl in
         Tstr_class_type
-          (List.map (fun (i, i_loc, d, _, _, _, _, c) ->
-               (i, i_loc, c)) classes),
+          (List.map (fun cl ->
+               (cl.Typeclass.clsty_ty_id,
+                cl.Typeclass.clsty_id_loc,
+                cl.Typeclass.clsty_info)) classes),
 (*  TODO: check with Jacques why this is here
            Tstr_type
              (List.map (fun (_, _, i, d, _, _) -> (i, d)) classes) ::
@@ -1410,10 +1420,11 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
              (List.map (fun (_, _, _, _, i, d) -> (i, d)) classes) :: *)
         List.flatten
           (map_rec
-             (fun rs (i, _, d, i', d', i'', d'', _) ->
-                [Sig_class_type(i, d, rs);
-                 Sig_type(i', d', rs);
-                 Sig_type(i'', d'', rs)])
+             (fun rs decl ->
+                let open Typeclass in
+                [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs);
+                 Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs);
+                 Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs)])
              classes []),
         new_env
     | Pstr_include sincl ->
@@ -1472,7 +1483,13 @@ let type_toplevel_phrase env 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 (str, sg, env) =
+    type_structure ~toplevel:true false None env s Location.none in
+  let (str, _coerce) = ImplementationHooks.apply_hooks
+      { Misc.sourcefile = "//toplevel//" } (str, Tcoerce_none)
+  in
+  (str, sg, env)
+
 let type_module_alias = type_module ~alias:true true false None
 let type_module = type_module true false None
 let type_structure = type_structure false None
@@ -1480,16 +1497,16 @@ let type_structure = type_structure false None
 (* Normalize types in a signature *)
 
 let rec normalize_modtype env = function
-    Mty_ident p -> ()
-  | Mty_alias p -> ()
+    Mty_ident _
+  | Mty_alias _ -> ()
   | Mty_signature sg -> normalize_signature env sg
-  | Mty_functor(id, param, body) -> normalize_modtype env body
+  | Mty_functor(_id, _param, body) -> normalize_modtype env body
 
 and normalize_signature env = List.iter (normalize_signature_item env)
 
 and normalize_signature_item env = function
-    Sig_value(id, desc) -> Ctype.normalize_type env desc.val_type
-  | Sig_module(id, md, _) -> normalize_modtype env md.md_type
+    Sig_value(_id, desc) -> Ctype.normalize_type env desc.val_type
+  | Sig_module(_id, md, _) -> normalize_modtype env md.md_type
   | _ -> ()
 
 (* Extract the module type of a module expression *)
@@ -1515,7 +1532,7 @@ let type_module_type_of env smod =
 
 (* For Typecore *)
 
-let type_package env m p nl tl =
+let type_package env m p nl =
   (* Same as Pexp_letmodule *)
   (* remember original level *)
   let lv = Ctype.get_current_level () in
@@ -1528,7 +1545,7 @@ let type_package env m p nl tl =
   let (mp, env) =
     match modl.mod_desc with
       Tmod_ident (mp,_) -> (mp, env)
-    | Tmod_constraint ({mod_desc=Tmod_ident (mp,_)}, mty, Tmodtype_implicit, _)
+    | Tmod_constraint ({mod_desc=Tmod_ident (mp,_)}, _, Tmodtype_implicit, _)
         -> (mp, env)  (* PR#6982 *)
     | _ ->
       let (id, new_env) = Env.enter_module ~arg:true "%M" modl.mod_type env in
@@ -1587,7 +1604,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
     (str, Tcoerce_none)   (* result is ignored by Compile.implementation *)
   end else begin
     let sourceintf =
-      Misc.chop_extension_if_any sourcefile ^ !Config.interface_suffix in
+      Filename.remove_extension sourcefile ^ !Config.interface_suffix in
     if Sys.file_exists sourceintf then begin
       let intf_file =
         try
@@ -1636,17 +1653,20 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
       (Some sourcefile) initial_env None;
     raise e
 
+let type_implementation sourcefile outputprefix modulename initial_env ast =
+  ImplementationHooks.apply_hooks { Misc.sourcefile }
+    (type_implementation sourcefile outputprefix modulename initial_env ast)
 
 let save_signature modname tsg outputprefix source_file initial_env cmi =
   Cmt_format.save_cmt  (outputprefix ^ ".cmti") modname
     (Cmt_format.Interface tsg) (Some source_file) initial_env (Some cmi)
 
-let type_interface env ast =
+let type_interface sourcefile env ast =
   begin
     let iter = Builtin_attributes.emit_external_warnings in
     iter.Ast_iterator.signature iter ast
   end;
-  transl_signature env ast
+  InterfaceHooks.apply_hooks { Misc.sourcefile } (transl_signature env ast)
 
 (* "Packaging" of several compilation units into one unit
    having them as sub-modules.  *)
@@ -1682,7 +1702,7 @@ let package_units initial_env objfiles cmifile modulename =
   Ident.reinit();
   let sg = package_signatures Subst.identity units in
   (* See if explicit interface is provided *)
-  let prefix = chop_extension_if_any cmifile in
+  let prefix = Filename.remove_extension cmifile in
   let mlifile = prefix ^ !Config.interface_suffix in
   if Sys.file_exists mlifile then begin
     if not (Sys.file_exists cmifile) then begin
@@ -1698,7 +1718,7 @@ let package_units initial_env objfiles cmifile modulename =
     let unit_names = List.map fst units in
     let imports =
       List.filter
-        (fun (name, crc) -> not (List.mem name unit_names))
+        (fun (name, _crc) -> not (List.mem name unit_names))
         (Env.imports()) in
     (* Write packaged signature *)
     if not !Clflags.dont_write_files then begin
diff --git a/typing/typemod.mli b/typing/typemod.mli
index 975a5a68..40172bcc 100644
--- a/typing/typemod.mli
+++ b/typing/typemod.mli
@@ -30,7 +30,7 @@ val type_implementation:
   string -> string -> string -> Env.t -> Parsetree.structure ->
   Typedtree.structure * Typedtree.module_coercion
 val type_interface:
-        Env.t -> Parsetree.signature -> Typedtree.signature
+        string -> Env.t -> Parsetree.signature -> Typedtree.signature
 val transl_signature:
         Env.t -> Parsetree.signature -> Typedtree.signature
 val check_nongen_schemes:
@@ -79,3 +79,9 @@ exception Error of Location.t * Env.t * error
 exception Error_forward of Location.error
 
 val report_error: Env.t -> formatter -> error -> unit
+
+
+module ImplementationHooks : Misc.HookSig
+  with type t = Typedtree.structure * Typedtree.module_coercion
+module InterfaceHooks : Misc.HookSig
+  with type t = Typedtree.signature
diff --git a/typing/types.ml b/typing/types.ml
index c9083810..0e85644f 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -149,6 +149,7 @@ type type_declaration =
     type_loc: Location.t;
     type_attributes: Parsetree.attributes;
     type_immediate: bool;
+    type_unboxed: unboxed_status;
  }
 
 and type_kind =
@@ -160,6 +161,7 @@ and type_kind =
 and record_representation =
     Record_regular                      (* All fields are boxed / tagged *)
   | Record_float                        (* All fields are floats *)
+  | Record_unboxed of bool    (* Unboxed single-field record, inlined or not *)
   | Record_inlined of int               (* Inlined record *)
   | Record_extension                    (* Inlined record under extension *)
 
@@ -185,6 +187,17 @@ and constructor_arguments =
   | Cstr_tuple of type_expr list
   | Cstr_record of label_declaration list
 
+and unboxed_status =
+  {
+    unboxed: bool;
+    default: bool; (* False if the unboxed field was set from an attribute. *)
+  }
+
+let unboxed_false_default_false = {unboxed = false; default = false}
+let unboxed_false_default_true = {unboxed = false; default = true}
+let unboxed_true_default_false = {unboxed = true; default = false}
+let unboxed_true_default_true = {unboxed = true; default = true}
+
 type extension_constructor =
     { ext_type_path: Path.t;
       ext_type_params: type_expr list;
@@ -240,7 +253,11 @@ type module_type =
     Mty_ident of Path.t
   | Mty_signature of signature
   | Mty_functor of Ident.t * module_type option * module_type
-  | Mty_alias of Path.t
+  | Mty_alias of alias_presence * Path.t
+
+and alias_presence =
+  | Mta_present
+  | Mta_absent
 
 and signature = signature_item list
 
@@ -301,6 +318,7 @@ type constructor_description =
 and constructor_tag =
     Cstr_constant of int                (* Constant constructor (an int) *)
   | Cstr_block of int                   (* Regular constructor (a block) *)
+  | Cstr_unboxed                        (* Constructor of an unboxed type *)
   | Cstr_extension of Path.t * bool     (* Extension constructor
                                            true if a constant false if a block*)
 
diff --git a/typing/types.mli b/typing/types.mli
index 45c9ddc6..2dc1481e 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -295,6 +295,7 @@ type type_declaration =
     type_loc: Location.t;
     type_attributes: Parsetree.attributes;
     type_immediate: bool; (* true iff type should not be a pointer *)
+    type_unboxed: unboxed_status;
   }
 
 and type_kind =
@@ -306,6 +307,7 @@ and type_kind =
 and record_representation =
     Record_regular                      (* All fields are boxed / tagged *)
   | Record_float                        (* All fields are floats *)
+  | Record_unboxed of bool    (* Unboxed single-field record, inlined or not *)
   | Record_inlined of int               (* Inlined record *)
   | Record_extension                    (* Inlined record under extension *)
 
@@ -331,6 +333,20 @@ and constructor_arguments =
   | Cstr_tuple of type_expr list
   | Cstr_record of label_declaration list
 
+and unboxed_status = private
+  (* This type must be private in order to ensure perfect sharing of the
+     four possible values. Otherwise, ocamlc.byte and ocamlc.opt produce
+     different executables. *)
+  {
+    unboxed: bool;
+    default: bool; (* True for unannotated unboxable types. *)
+  }
+
+val unboxed_false_default_false : unboxed_status
+val unboxed_false_default_true : unboxed_status
+val unboxed_true_default_false : unboxed_status
+val unboxed_true_default_true : unboxed_status
+
 type extension_constructor =
     {
       ext_type_path: Path.t;
@@ -388,7 +404,11 @@ type module_type =
     Mty_ident of Path.t
   | Mty_signature of signature
   | Mty_functor of Ident.t * module_type option * module_type
-  | Mty_alias of Path.t
+  | Mty_alias of alias_presence * Path.t
+
+and alias_presence =
+  | Mta_present
+  | Mta_absent
 
 and signature = signature_item list
 
@@ -449,6 +469,7 @@ type constructor_description =
 and constructor_tag =
     Cstr_constant of int                (* Constant constructor (an int) *)
   | Cstr_block of int                   (* Regular constructor (a block) *)
+  | Cstr_unboxed                        (* Constructor of an unboxed type *)
   | Cstr_extension of Path.t * bool     (* Extension constructor
                                            true if a constant false if a block*)
 
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index a1ca6a12..e0d06dd1 100644
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -73,7 +73,7 @@ let instance_list = Ctype.instance_list Env.empty
 let rec narrow_unbound_lid_error : 'a. _ -> _ -> _ -> _ -> 'a =
   fun env loc lid make_error ->
   let check_module mlid =
-    try ignore (Env.lookup_module true mlid env) with
+    try ignore (Env.lookup_module ~load:true mlid env) with
     | Not_found ->
         narrow_unbound_lid_error env loc mlid (fun lid -> Unbound_module lid)
     | Env.Recmodule ->
@@ -83,28 +83,28 @@ let rec narrow_unbound_lid_error : 'a. _ -> _ -> _ -> _ -> 'a =
   | Longident.Lident _ -> ()
   | Longident.Ldot (mlid, _) ->
       check_module mlid;
-      let md = Env.find_module (Env.lookup_module true mlid env) env in
+      let md = Env.find_module (Env.lookup_module ~load:true mlid env) env in
       begin match Env.scrape_alias env md.md_type with
       | Mty_functor _ ->
           raise (Error (loc, env, Access_functor_as_structure mlid))
-      | Mty_alias p ->
+      | Mty_alias(_, p) ->
           raise (Error (loc, env, Cannot_scrape_alias(mlid, p)))
       | _ -> ()
       end
   | Longident.Lapply (flid, mlid) ->
       check_module flid;
-      let fmd = Env.find_module (Env.lookup_module true flid env) env in
+      let fmd = Env.find_module (Env.lookup_module ~load:true flid env) env in
       begin match Env.scrape_alias env fmd.md_type with
       | Mty_signature _ ->
           raise (Error (loc, env, Apply_structure_as_functor flid))
-      | Mty_alias p ->
+      | Mty_alias(_, p) ->
           raise (Error (loc, env, Cannot_scrape_alias(flid, p)))
       | _ -> ()
       end;
       check_module mlid;
-      let mmd = Env.find_module (Env.lookup_module true mlid env) env in
+      let mmd = Env.find_module (Env.lookup_module ~load:true mlid env) env in
       begin match Env.scrape_alias env mmd.md_type with
-      | Mty_alias p ->
+      | Mty_alias(_, p) ->
           raise (Error (loc, env, Cannot_scrape_alias(mlid, p)))
       | _ ->
           raise (Error (loc, env, Ill_typed_functor_application lid))
@@ -112,25 +112,26 @@ let rec narrow_unbound_lid_error : 'a. _ -> _ -> _ -> _ -> 'a =
   end;
   raise (Error (loc, env, make_error lid))
 
-let find_component lookup make_error env loc lid =
+let find_component (lookup : ?loc:_ -> _) make_error env loc lid =
   try
     match lid with
     | Longident.Ldot (Longident.Lident "*predef*", s) ->
-        lookup ?loc:(Some loc) (Longident.Lident s) Env.initial_safe_string
+        lookup ~loc (Longident.Lident s) Env.initial_safe_string
     | _ ->
-        lookup ?loc:(Some loc) lid env
+        lookup ~loc lid env
   with Not_found ->
     narrow_unbound_lid_error env loc lid make_error
   | Env.Recmodule ->
     raise (Error (loc, env, Illegal_reference_to_recursive_module))
 
 let find_type env loc lid =
-  let (path, decl) as r =
+  let path =
     find_component Env.lookup_type (fun lid -> Unbound_type_constructor lid)
       env loc lid
   in
+  let decl = Env.find_type path env in
   Builtin_attributes.check_deprecated loc decl.type_attributes (Path.name path);
-  r
+  (path, decl)
 
 let find_constructor =
   find_component Env.lookup_constructor (fun lid -> Unbound_constructor lid)
@@ -199,7 +200,7 @@ let transl_modtype = ref (fun _ -> assert false)
 let create_package_mty fake loc env (p, l) =
   let l =
     List.sort
-      (fun (s1, t1) (s2, t2) ->
+      (fun (s1, _t1) (s2, _t2) ->
          if s1.txt = s2.txt then
            raise (Error (loc, env, Multiple_constraints_on_type s1.txt));
          compare s1.txt s2.txt)
@@ -379,9 +380,10 @@ let rec transl_type env policy styp =
       let ty = newobj (transl_fields loc env policy [] o fields) in
       ctyp (Ttyp_object (fields, o)) ty
   | Ptyp_class(lid, stl) ->
-      let (path, decl, is_variant) =
+      let (path, decl, _is_variant) =
         try
-          let (path, decl) = Env.lookup_type lid.txt env in
+          let path = Env.lookup_type lid.txt env in
+          let decl = Env.find_type path env in
           let rec check decl =
             match decl.type_manifest with
               None -> raise Not_found
@@ -402,7 +404,8 @@ let rec transl_type env policy styp =
             | Longident.Ldot(r, s)   -> Longident.Ldot (r, "#" ^ s)
             | Longident.Lapply(_, _) -> fatal_error "Typetexp.transl_type"
           in
-          let (path, decl) = Env.lookup_type lid2 env in
+          let path = Env.lookup_type lid2 env in
+          let decl = Env.find_type path env in
           (path, decl, false)
         with Not_found ->
           ignore (find_class env styp.ptyp_loc lid.txt); assert false
@@ -509,7 +512,7 @@ let rec transl_type env policy styp =
           let ty = mkfield l f and ty' = mkfield l f' in
           if equal env false [ty] [ty'] then () else
           try unify env ty ty'
-          with Unify trace ->
+          with Unify _trace ->
             raise(Error(loc, env, Constructor_mismatch (ty,ty')))
         with Not_found ->
           Hashtbl.add hfields h (l,f)
@@ -632,7 +635,7 @@ let rec transl_type env policy styp =
                           ) l in
       let path = !transl_modtype_longident styp.ptyp_loc env p.txt in
       let ty = newty (Tpackage (path,
-                       List.map (fun (s, pty) -> s.txt) l,
+                       List.map (fun (s, _pty) -> s.txt) l,
                        List.map (fun (_,cty) -> cty.ctyp_type) ptys))
       in
       ctyp (Ttyp_package {
@@ -673,7 +676,7 @@ let rec make_fixed_univars ty =
               {row with row_fixed=true;
                row_fields = List.map
                  (fun (s,f as p) -> match Btype.row_field_repr f with
-                   Reither (c, tl, m, r) -> s, Reither (c, tl, true, r)
+                   Reither (c, tl, _m, r) -> s, Reither (c, tl, true, r)
                  | _ -> p)
                  row.row_fields};
         Btype.iter_row make_fixed_univars row
diff --git a/typing/untypeast.ml b/typing/untypeast.ml
index 2f0c26d5..3b62145d 100644
--- a/typing/untypeast.ml
+++ b/typing/untypeast.ml
@@ -410,11 +410,13 @@ let expression sub exp =
           ))
     | Texp_variant (label, expo) ->
         Pexp_variant (label, map_opt (sub.expr sub) expo)
-    | Texp_record (list, expo) ->
-        Pexp_record (List.map (fun (lid, _, exp) ->
-              (map_loc sub lid, sub.expr sub exp)
-          ) list,
-          map_opt (sub.expr sub) expo)
+    | Texp_record { fields; extended_expression; _ } ->
+        let list = Array.fold_left (fun l -> function
+            | _, Kept _ -> l
+            | _, Overridden (lid, exp) -> (lid, sub.expr sub exp) :: l)
+            [] fields
+        in
+        Pexp_record (list, map_opt (sub.expr sub) extended_expression)
     | Texp_field (exp, lid, _label) ->
         Pexp_field (sub.expr sub exp, map_loc sub lid)
     | Texp_setfield (exp1, lid, _label, exp2) ->
@@ -450,6 +452,9 @@ let expression sub exp =
     | Texp_letmodule (_id, name, mexpr, exp) ->
         Pexp_letmodule (name, sub.module_expr sub mexpr,
           sub.expr sub exp)
+    | Texp_letexception (ext, exp) ->
+        Pexp_letexception (sub.extension_constructor sub ext,
+                           sub.expr sub exp)
     | Texp_assert exp -> Pexp_assert (sub.expr sub exp)
     | Texp_lazy exp -> Pexp_lazy (sub.expr sub exp)
     | Texp_object (cl, _) ->
@@ -747,7 +752,7 @@ let class_field sub cf =
   in
   Cf.mk ~loc ~attrs desc
 
-let location sub l = l
+let location _sub l = l
 
 let default_mapper =
   {
diff --git a/utils/arg_helper.ml b/utils/arg_helper.ml
index 15061e33..fa80007a 100644
--- a/utils/arg_helper.ml
+++ b/utils/arg_helper.ml
@@ -58,15 +58,12 @@ end) = struct
   let add_user_override key value t =
     { t with user_override = S.Key.Map.add key value t.user_override }
 
-  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
+    (* Is the removal of empty chunks really relevant here? *)
+    (* (It has been added to mimic the old Misc.String.split.) *)
+    let values = String.split_on_char ',' str |> List.filter ((<>) "") in
     let parsed =
       List.fold_left (fun acc value ->
           match String.index value '=' with
@@ -101,7 +98,7 @@ end) = struct
     in
     update := parsed
 
-  let parse str ~help_text ~update =
+  let parse str help_text update =
     match parse_exn str ~update with
     | () -> ()
     | exception (Parse_failure exn) ->
@@ -111,7 +108,7 @@ end) = struct
     | Ok
     | Parse_failed of exn
 
-  let parse_no_error str ~update =
+  let parse_no_error str update =
     match parse_exn str ~update with
     | () -> Ok
     | exception (Parse_failure exn) -> Parse_failed exn
diff --git a/utils/arg_helper.mli b/utils/arg_helper.mli
index d877d755..fba7aa21 100644
--- a/utils/arg_helper.mli
+++ b/utils/arg_helper.mli
@@ -51,13 +51,13 @@ end) : sig
 
   val add_user_override : S.Key.t -> S.Value.t -> parsed -> parsed
 
-  val parse : string -> help_text:string -> update:parsed ref -> unit
+  val parse : string -> string -> parsed ref -> unit
 
   type parse_result =
     | Ok
     | Parse_failed of exn
 
-  val parse_no_error : string -> update:parsed ref -> parse_result
+  val parse_no_error : string -> parsed ref -> parse_result
 
   val get : key:S.Key.t -> parsed -> S.Value.t
 end
diff --git a/utils/clflags.ml b/utils/clflags.ml
index b8ce959b..bd884872 100644
--- a/utils/clflags.ml
+++ b/utils/clflags.ml
@@ -67,6 +67,7 @@ and use_threads = ref false             (* -thread *)
 and use_vmthreads = ref false           (* -vmthread *)
 and noassert = ref false                (* -noassert *)
 and verbose = ref false                 (* -verbose *)
+and noversion = ref false               (* -no-version *)
 and noprompt = ref false                (* -noprompt *)
 and nopromptcont = ref false            (* -nopromptcont *)
 and init_file = ref (None : string option)   (* -init *)
@@ -152,7 +153,8 @@ 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 unsafe_string = ref (not Config.safe_string)
+                                   (* -safe-string / -unsafe-string *)
 
 let classic_inlining = ref false       (* -Oclassic *)
 let inlining_report = ref false    (* -inlining-report *)
@@ -354,3 +356,5 @@ let parse_color_setting = function
   | "never" -> Some Misc.Color.Never
   | _ -> None
 let color = ref Misc.Color.Auto ;; (* -color *)
+
+let unboxed_types = ref false
diff --git a/utils/clflags.mli b/utils/clflags.mli
index a5c9ec9b..f7939eb6 100644
--- a/utils/clflags.mli
+++ b/utils/clflags.mli
@@ -17,12 +17,12 @@
 module Int_arg_helper : sig
   type parsed
 
-  val parse : string -> help_text:string -> update:parsed ref -> unit
+  val parse : string -> string -> parsed ref -> unit
 
   type parse_result =
     | Ok
     | Parse_failed of exn
-  val parse_no_error : string -> update:parsed ref -> parse_result
+  val parse_no_error : string -> parsed ref -> parse_result
 
   val get : key:int -> parsed -> int
 end
@@ -31,12 +31,12 @@ end
 module Float_arg_helper : sig
   type parsed
 
-  val parse : string -> help_text:string -> update:parsed ref -> unit
+  val parse : string -> string -> parsed ref -> unit
 
   type parse_result =
     | Ok
     | Parse_failed of exn
-  val parse_no_error : string -> update:parsed ref -> parse_result
+  val parse_no_error : string -> parsed ref -> parse_result
 
   val get : key:int -> parsed -> float
 end
@@ -97,6 +97,7 @@ val noprompt : bool ref
 val nopromptcont : bool ref
 val init_file : string option ref
 val noinit : bool ref
+val noversion : bool ref
 val use_prims : string ref
 val use_runtime : string ref
 val principal : bool ref
@@ -199,3 +200,5 @@ val set_dumped_pass : string -> bool -> unit
 
 val parse_color_setting : string -> Misc.Color.setting option
 val color : Misc.Color.setting ref
+
+val unboxed_types : bool ref
diff --git a/utils/config.mli b/utils/config.mli
index c8feca6a..9b050056 100644
--- a/utils/config.mli
+++ b/utils/config.mli
@@ -138,3 +138,16 @@ val print_config : out_channel -> unit;;
 
 val flambda : bool
         (* Whether the compiler was configured for flambda *)
+
+val spacetime : bool
+        (* Whether the compiler was configured for Spacetime profiling *)
+val profinfo_width : int
+        (* How many bits are to be used in values' headers for profiling
+           information *)
+val libunwind_available : bool
+        (* Whether the libunwind library is available on the target *)
+val libunwind_link_flags : string
+        (* Linker flags to use libunwind *)
+
+val safe_string: bool
+        (* Whether the compiler was configured with -safe-string *)
diff --git a/utils/config.mlp b/utils/config.mlp
index df9c0c81..e821ef07 100644
--- a/utils/config.mlp
+++ b/utils/config.mlp
@@ -1,3 +1,4 @@
+#2 "utils/config.mlp"
 (**************************************************************************)
 (*                                                                        *)
 (*                                 OCaml                                  *)
@@ -67,9 +68,10 @@ let mkdll, mkexe, mkmaindll =
     "%%MKDLL%%", "%%MKEXE%%", "%%MKMAINDLL%%"
 
 let flambda = %%FLAMBDA%%
+let safe_string = %%SAFE_STRING%%
 
 let exec_magic_number = "Caml1999X011"
-and cmi_magic_number = "Caml1999I020"
+and cmi_magic_number = "Caml1999I021"
 and cmo_magic_number = "Caml1999O011"
 and cma_magic_number = "Caml1999A012"
 and cmx_magic_number =
@@ -82,10 +84,10 @@ and cmxa_magic_number =
     "Caml1999Z015"
   else
     "Caml1999Z014"
-and ast_impl_magic_number = "Caml1999M019"
+and ast_impl_magic_number = "Caml1999M020"
 and ast_intf_magic_number = "Caml1999N018"
 and cmxs_magic_number = "Caml2007D002"
-and cmt_magic_number = "Caml2012T007"
+and cmt_magic_number = "Caml2012T008"
 
 let load_path = ref ([] : string list)
 
@@ -108,6 +110,10 @@ let system = "%%SYSTEM%%"
 let asm = "%%ASM%%"
 let asm_cfi_supported = %%ASM_CFI_SUPPORTED%%
 let with_frame_pointers = %%WITH_FRAME_POINTERS%%
+let spacetime = %%WITH_SPACETIME%%
+let libunwind_available = %%LIBUNWIND_AVAILABLE%%
+let libunwind_link_flags = "%%LIBUNWIND_LINK_FLAGS%%"
+let profinfo_width = %%PROFINFO_WIDTH%%
 
 let ext_obj = "%%EXT_OBJ%%"
 let ext_asm = "%%EXT_ASM%%"
@@ -156,6 +162,8 @@ let print_config oc =
   p "host" host;
   p "target" target;
   p_bool "flambda" flambda;
+  p_bool "spacetime" spacetime;
+  p_bool "safe_string" safe_string;
 
   (* print the magic number *)
   p "exec_magic_number" exec_magic_number;
diff --git a/utils/consistbl.ml b/utils/consistbl.ml
index b9be8eca..dbba5d1f 100644
--- a/utils/consistbl.ml
+++ b/utils/consistbl.ml
@@ -57,7 +57,7 @@ let extract l tbl =
 let filter p tbl =
   let to_remove = ref [] in
   Hashtbl.iter
-    (fun name (crc, auth) ->
+    (fun name _ ->
       if not (p name) then to_remove := name :: !to_remove)
     tbl;
   List.iter
diff --git a/utils/identifiable.ml b/utils/identifiable.ml
index 4ff649af..0a2f3be9 100644
--- a/utils/identifiable.ml
+++ b/utils/identifiable.ml
@@ -66,7 +66,7 @@ module Make_map (T : Thing) = struct
       m1 m2
 
   let union_right m1 m2 =
-    merge (fun id x y -> match x, y with
+    merge (fun _id x y -> match x, y with
         | None, None -> None
         | None, Some v
         | Some v, None
@@ -104,6 +104,17 @@ module Make_map (T : Thing) = struct
   let of_set f set = T_set.fold (fun e map -> add e (f e) map) set empty
 
   let transpose_keys_and_data map = fold (fun k v m -> add v k m) map empty
+  let transpose_keys_and_data_set map =
+    fold (fun k v m ->
+        let set =
+          match find v m with
+          | exception Not_found ->
+            T_set.singleton k
+          | set ->
+            T_set.add k set
+        in
+        add v set m)
+      map empty
 end
 
 module Make_set (T : Thing) = struct
@@ -194,6 +205,7 @@ module type S = sig
     val data : 'a t -> 'a list
     val of_set : (key -> 'a) -> Make_set (T).t -> 'a t
     val transpose_keys_and_data : key t -> key t
+    val transpose_keys_and_data_set : key t -> Set.t t
     val print :
       (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
   end
diff --git a/utils/identifiable.mli b/utils/identifiable.mli
index b47ce6af..255a6a59 100644
--- a/utils/identifiable.mli
+++ b/utils/identifiable.mli
@@ -73,6 +73,7 @@ module type S = sig
     val data : 'a t -> 'a list
     val of_set : (key -> 'a) -> Set.t -> 'a t
     val transpose_keys_and_data : key t -> key t
+    val transpose_keys_and_data_set : key t -> Set.t t
     val print :
       (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
   end
diff --git a/utils/misc.ml b/utils/misc.ml
index 5e9d7e46..8ff77775 100644
--- a/utils/misc.ml
+++ b/utils/misc.ml
@@ -30,6 +30,17 @@ let try_finally work cleanup =
   result
 ;;
 
+type ref_and_value = R : 'a ref * 'a -> ref_and_value
+
+let protect_refs =
+  let set_refs l = List.iter (fun (R (r, v)) -> r := v) l in
+  fun refs f ->
+    let backup = List.map (fun (R (r, _)) -> R (r, !r)) refs in
+    set_refs refs;
+    match f () with
+    | x           -> set_refs backup; x
+    | exception e -> set_refs backup; raise e
+
 (* List functions *)
 
 let rec map_end f l1 l2 =
@@ -63,24 +74,6 @@ let rec split_last = function
       (hd :: lst, last)
 
 module Stdlib = struct
-  module String = struct
-    type t = string
-
-    let split s ~on =
-      let is_separator c = (c = on) in
-      let rec split1 res i =
-        if i >= String.length s then res else begin
-          if is_separator s.[i] then split1 res (i+1)
-          else split2 res i (i+1)
-        end
-      and split2 res i j =
-        if j >= String.length s then String.sub s i (j-i) :: res else begin
-          if is_separator s.[j] then split1 (String.sub s i (j-i) :: res) (j+1)
-          else split2 res i (j+1)
-        end
-      in List.rev (split1 [] 0)
-  end
-
   module List = struct
     type 'a t = 'a list
 
@@ -115,7 +108,7 @@ module Stdlib = struct
       let rec aux acc l1 l2 =
         match l1, l2 with
         | [], _ -> (List.rev acc, l2)
-        | h::t, [] -> raise (Invalid_argument "map2_prefix")
+        | _ :: _, [] -> raise (Invalid_argument "map2_prefix")
         | h1::t1, h2::t2 ->
           let h = f h1 h2 in
           aux (h :: acc) t1 t2
@@ -221,7 +214,7 @@ let remove_file filename =
   try
     if Sys.file_exists filename
     then Sys.remove filename
-  with Sys_error msg ->
+  with Sys_error _msg ->
     ()
 
 (* Expand a -I option: if it starts with +, make it relative to the standard
@@ -298,9 +291,6 @@ end
 
 (* String operations *)
 
-let chop_extension_if_any fname =
-  try Filename.chop_extension fname with Invalid_argument _ -> fname
-
 let chop_extensions file =
   let dirname = Filename.dirname file and basename = Filename.basename file in
   try
@@ -484,22 +474,6 @@ let did_you_mean ppf get_choices =
        (if rest = [] then "" else " or ")
        last
 
-(* split a string [s] at every char [c], and return the list of sub-strings *)
-let split s c =
-  let len = String.length s in
-  let rec iter pos to_rev =
-    if pos = len then List.rev ("" :: to_rev) else
-      match try
-              Some ( String.index_from s pos c )
-        with Not_found -> None
-      with
-          Some pos2 ->
-            if pos2 = pos then iter (pos+1) ("" :: to_rev) else
-              iter (pos2+1) ((String.sub s pos (pos2-pos)) :: to_rev)
-        | None -> List.rev ( String.sub s pos (len-pos) :: to_rev )
-  in
-  iter 0 []
-
 let cut_at s c =
   let pos = String.index s c in
   String.sub s 0 pos, String.sub s (pos+1) (String.length s - pos - 1)
@@ -641,3 +615,82 @@ let normalise_eol s =
       if s.[i] <> '\r' then Buffer.add_char b s.[i]
     done;
     Buffer.contents b
+
+let delete_eol_spaces src =
+  let len_src = String.length src in
+  let dst = Bytes.create len_src in
+  let rec loop i_src i_dst =
+    if i_src = len_src then
+      i_dst
+    else
+      match src.[i_src] with
+      | ' ' | '\t' ->
+        loop_spaces 1 (i_src + 1) i_dst
+      | c ->
+        Bytes.set dst i_dst c;
+        loop (i_src + 1) (i_dst + 1)
+  and loop_spaces spaces i_src i_dst =
+    if i_src = len_src then
+      i_dst
+    else
+      match src.[i_src] with
+      | ' ' | '\t' ->
+        loop_spaces (spaces + 1) (i_src + 1) i_dst
+      | '\n' ->
+        Bytes.set dst i_dst '\n';
+        loop (i_src + 1) (i_dst + 1)
+      | _ ->
+        for n = 0 to spaces do
+          Bytes.set dst (i_dst + n) src.[i_src - spaces + n]
+        done;
+        loop (i_src + 1) (i_dst + spaces + 1)
+  in
+  let stop = loop 0 0 in
+  Bytes.sub_string dst 0 stop
+
+type hook_info = {
+  sourcefile : string;
+}
+
+exception HookExnWrapper of
+    {
+      error: exn;
+      hook_name: string;
+      hook_info: hook_info;
+    }
+
+exception HookExn of exn
+
+let raise_direct_hook_exn e = raise (HookExn e)
+
+let fold_hooks list hook_info ast =
+  List.fold_left (fun ast (hook_name,f) ->
+    try
+      f hook_info ast
+    with
+    | HookExn e -> raise e
+    | error -> raise (HookExnWrapper {error; hook_name; hook_info})
+       (* when explicit reraise with backtrace will be available,
+          it should be used here *)
+
+  ) ast (List.sort compare list)
+
+module type HookSig = sig
+  type t
+
+  val add_hook : string -> (hook_info -> t -> t) -> unit
+  val apply_hooks : hook_info -> t -> t
+end
+
+module MakeHooks(M: sig
+    type t
+  end) : HookSig with type t = M.t
+= struct
+
+  type t = M.t
+
+  let hooks = ref []
+  let add_hook name f = hooks := (name, f) :: !hooks
+  let apply_hooks sourcefile intf =
+    fold_hooks !hooks sourcefile intf
+end
diff --git a/utils/misc.mli b/utils/misc.mli
index be5d23c2..bdcbae95 100644
--- a/utils/misc.mli
+++ b/utils/misc.mli
@@ -40,6 +40,13 @@ val split_last: 'a list -> 'a list * 'a
 val may: ('a -> unit) -> 'a option -> unit
 val may_map: ('a -> 'b) -> 'a option -> 'b option
 
+type ref_and_value = R : 'a ref * 'a -> ref_and_value
+
+val protect_refs : ref_and_value list -> (unit -> 'a) -> 'a
+(** [protect_refs l f] temporarily sets [r] to [v] for each [R (r, v)] in [l]
+    while executing [f]. The previous contents of the references is restored
+    even if [f] raises an exception. *)
+
 module Stdlib : sig
   module List : sig
     type 'a t = 'a list
@@ -83,15 +90,6 @@ module Stdlib : sig
     val fold : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
     val value_default : ('a -> 'b) -> default:'b -> 'a t -> 'b
   end
-
-  module String : sig
-    type t = string
-
-    val split : t -> on:char -> t list
-    (** Splits the given string at every occurrence of the given separator.
-        Does not return empty substrings when the separator is repeated or
-        present at the start or end of the string. *)
-  end
 end
 
 val find_in_path: string list -> string -> string
@@ -148,10 +146,6 @@ module Int_literal_converter : sig
   val nativeint : string -> nativeint
 end
 
-val chop_extension_if_any: string -> string
-        (* Like Filename.chop_extension but returns the initial file
-           name if it has no extension *)
-
 val chop_extensions: string -> string
         (* Return the given file name without its extensions. The extensions
            is the longest suffix starting with a period and not including
@@ -232,13 +226,6 @@ val did_you_mean : Format.formatter -> (unit -> string list) -> unit
     the failure even if producing the hint is slow.
 *)
 
-val split : string -> char -> string list
-(** [String.split string char] splits the string [string] at every char
-    [char], and returns the list of sub-strings between the chars.
-    [String.concat (String.make 1 c) (String.split s c)] is the identity.
-    @since 4.01
- *)
-
 val cut_at : string -> char -> string * string
 (** [String.cut_at s c] returns a pair containing the sub-string before
    the first occurrence of [c] in [s], and the sub-string after the
@@ -303,3 +290,44 @@ 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) *)
+
+val delete_eol_spaces : string -> string
+(** [delete_eol_spaces s] returns a fresh copy of [s] with any end of
+   line spaces removed. Intended to normalize the output of the
+   toplevel for tests. *)
+
+
+
+(** {2 Hook machinery} *)
+
+(* Hooks machinery:
+   [add_hook name f] will register a function that will be called on the
+    argument of a later call to [apply_hooks]. Hooks are applied in the
+    lexicographical order of their names.
+*)
+
+type hook_info = {
+  sourcefile : string;
+}
+
+exception HookExnWrapper of
+    {
+      error: exn;
+      hook_name: string;
+      hook_info: hook_info;
+    }
+    (** An exception raised by a hook will be wrapped into a
+        [HookExnWrapper] constructor by the hook machinery.  *)
+
+
+val raise_direct_hook_exn: exn -> 'a
+  (** A hook can use [raise_unwrapped_hook_exn] to raise an exception that will
+      not be wrapped into a [HookExnWrapper]. *)
+
+module type HookSig = sig
+  type t
+  val add_hook : string -> (hook_info -> t -> t) -> unit
+  val apply_hooks : hook_info -> t -> t
+end
+
+module MakeHooks : functor (M : sig type t end) -> HookSig with type t = M.t
diff --git a/utils/strongly_connected_components.ml b/utils/strongly_connected_components.ml
index ba9b4546..a11f6987 100644
--- a/utils/strongly_connected_components.ml
+++ b/utils/strongly_connected_components.ml
@@ -131,7 +131,8 @@ module Make (Id : Identifiable.S) = struct
     | No_loop of Id.t
 
   (* Ensure that the dependency graph does not have external dependencies. *)
-  let check dependencies =
+  (* Note: this function is currently not used. *)
+  let _check dependencies =
     Id.Map.iter (fun id set ->
         Id.Set.iter (fun v ->
             if not (Id.Map.mem v dependencies)
diff --git a/utils/tbl.ml b/utils/tbl.ml
index 4b03fe62..abb7309b 100644
--- a/utils/tbl.ml
+++ b/utils/tbl.ml
@@ -68,7 +68,7 @@ let rec find x = function
 
 let rec mem x = function
     Empty -> false
-  | Node(l, v, d, r, _) ->
+  | Node(l, v, _d, r, _) ->
       let c = compare x v in
       c = 0 || mem x (if c < 0 then l else r)
 
@@ -76,13 +76,13 @@ let rec merge t1 t2 =
   match (t1, t2) with
     (Empty, t) -> t
   | (t, Empty) -> t
-  | (Node(l1, v1, d1, r1, h1), Node(l2, v2, d2, r2, h2)) ->
+  | (Node(l1, v1, d1, r1, _h1), Node(l2, v2, d2, r2, _h2)) ->
       bal l1 v1 d1 (bal (merge r1 l2) v2 d2 r2)
 
 let rec remove x = function
     Empty ->
       Empty
-  | Node(l, v, d, r, h) ->
+  | Node(l, v, d, r, _h) ->
       let c = compare x v in
       if c = 0 then
         merge l r
diff --git a/utils/warnings.ml b/utils/warnings.ml
index 6a22cf0b..f2e08580 100644
--- a/utils/warnings.ml
+++ b/utils/warnings.ml
@@ -14,10 +14,10 @@
 (**************************************************************************)
 
 (* When you change this, you need to update the documentation:
-   - man/ocamlc.m   in ocaml
-   - man/ocamlopt.m in ocaml
-   - manual/cmds/comp.etex   in the doc sources
-   - manual/cmds/native.etex in the doc sources
+   - man/ocamlc.m
+   - man/ocamlopt.m
+   - manual/manual/cmds/comp.etex
+   - manual/manual/cmds/native.etex
 *)
 
 type t =
@@ -58,7 +58,7 @@ type t =
   | Unused_for_index of string              (* 35 *)
   | Unused_ancestor of string               (* 36 *)
   | Unused_constructor of string * bool * bool  (* 37 *)
-  | Unused_extension of string * bool * bool    (* 38 *)
+  | Unused_extension of string * bool * bool * bool (* 38 *)
   | Unused_rec_flag                         (* 39 *)
   | Name_out_of_scope of string * string list * bool (* 40 *)
   | Ambiguous_name of string list * string list *  bool    (* 41 *)
@@ -80,6 +80,8 @@ type t =
   | Ambiguous_pattern of string list        (* 57 *)
   | No_cmx_file of string                   (* 58 *)
   | Assignment_to_non_mutable_value         (* 59 *)
+  | Unused_module of string                 (* 60 *)
+  | Unboxable_type_in_prim_decl of string   (* 61 *)
 ;;
 
 (* If you remove a warning, leave a hole in the numbering.  NEVER change
@@ -148,9 +150,11 @@ let number = function
   | Ambiguous_pattern _ -> 57
   | No_cmx_file _ -> 58
   | Assignment_to_non_mutable_value -> 59
+  | Unused_module _ -> 60
+  | Unboxable_type_in_prim_decl _ -> 61
 ;;
 
-let last_warning_number = 59
+let last_warning_number = 61
 ;;
 
 (* Must be the max number returned by the [number] function. *)
@@ -239,7 +243,7 @@ let parse_opt error active flags s =
     | '+' -> loop_letter_num set (i+1)
     | '-' -> loop_letter_num clear (i+1)
     | '@' -> loop_letter_num set_all (i+1)
-    | c -> error ()
+    | _ -> error ()
   and loop_letter_num myset i =
     if i >= String.length s then error () else
     match s.[i] with
@@ -265,7 +269,7 @@ let parse_options errflag s =
   current := {error; active}
 
 (* If you change these, don't forget to change them in man/ocamlc.m *)
-let defaults_w = "+a-4-6-7-9-27-29-32..39-41..42-44-45-48-50";;
+let defaults_w = "+a-4-6-7-9-27-29-32..39-41..42-44-45-48-50-60";;
 let defaults_warn_error = "-a+31";;
 
 let () = parse_options false defaults_w;;
@@ -306,7 +310,7 @@ let message = function
   | Partial_match "" -> "this pattern-matching is not exhaustive."
   | Partial_match s ->
       "this pattern-matching is not exhaustive.\n\
-       Here is an example of a value that is not matched:\n" ^ s
+       Here is an example of a case that is not matched:\n" ^ s
   | Non_closed_record_pattern s ->
       "the following labels are not bound in this record pattern:\n" ^ s ^
       "\nEither bind these labels explicitly or add '; _' to the pattern."
@@ -369,16 +373,21 @@ let message = function
       "constructor " ^ s ^
       " is never used to build values.\n\
         Its type is exported as a private type."
-  | Unused_extension (s, false, false) ->
-      "unused extension constructor " ^ s ^ "."
-  | Unused_extension (s, true, _) ->
-      "extension constructor " ^ s ^
-      " is never used to build values.\n\
-        (However, this constructor appears in patterns.)"
-  | Unused_extension (s, false, true) ->
-      "extension constructor " ^ s ^
-      " is never used to build values.\n\
-        It is exported or rebound as a private extension."
+  | Unused_extension (s, is_exception, cu_pattern, cu_privatize) ->
+     let kind =
+       if is_exception then "exception" else "extension constructor" in
+     let name = kind ^ " " ^ s in
+     begin match cu_pattern, cu_privatize with
+       | false, false -> "unused " ^ name
+       | true, _ ->
+          name ^
+          " is never used to build values.\n\
+           (However, this constructor appears in patterns.)"
+       | false, true ->
+          name ^
+          " is never used to build values.\n\
+            It is exported or rebound as a private extension."
+     end
   | Unused_rec_flag ->
       "unused rec flag."
   | Name_out_of_scope (ty, [nm], false) ->
@@ -395,12 +404,13 @@ let message = function
       s ^ " belongs to several types: " ^ String.concat " " tl ^
       "\nThe first one was selected. Please disambiguate if this is wrong."
   | Ambiguous_name (_, _, false) -> assert false
-  | Ambiguous_name (slist, tl, true) ->
+  | Ambiguous_name (_slist, tl, true) ->
       "these field labels belong to several types: " ^
       String.concat " " tl ^
       "\nThe first one was selected. Please disambiguate if this is wrong."
   | Disambiguated_name s ->
-      "this use of " ^ s ^ " required disambiguation."
+      "this use of " ^ s ^ " relies on type-directed disambiguation,\n\
+       it will not compile with OCaml 4.00 or earlier."
   | Nonoptional_label s ->
       "the label " ^ s ^ " is not optional."
   | Open_shadow_identifier (kind, s) ->
@@ -432,9 +442,9 @@ let message = function
       Printf.sprintf "expected tailcall"
   | Fragile_literal_pattern ->
       Printf.sprintf
-        "the argument of this constructor should not be matched against a\n\
-         constant pattern; the actual value of the argument could change\n\
-         in the future."
+        "Code should not depend on the actual values of\n\
+         this constructor's arguments. They are only for information\n\
+         and may change in future versions. (See manual section 8.5)"
   | Unreachable_case ->
       "this match case is unreachable.\n\
        Consider replacing it with a refutation case ' -> .'"
@@ -466,6 +476,13 @@ let message = function
       "A potential assignment to a non-mutable value was detected \n\
         in this source file.  Such assignments may generate incorrect code \n\
         when using Flambda."
+  | Unused_module s -> "unused module " ^ s ^ "."
+  | Unboxable_type_in_prim_decl t ->
+      Printf.sprintf
+        "This primitive declaration uses type %s, which is unannotated and\n\
+         unboxable. The representation of such types may change in future\n\
+         versions. You should annotate the declaration of %s with [@@boxed]\n\
+         or [@@unboxed]." t t
 ;;
 
 let nerrors = ref 0;;
@@ -547,7 +564,7 @@ let descriptions =
    39, "Unused rec flag.";
    40, "Constructor or label name used out of scope.";
    41, "Ambiguous constructor or label name.";
-   42, "Disambiguated constructor or label name.";
+   42, "Disambiguated constructor or label name (compatibility warning).";
    43, "Nonoptional label applied as optional.";
    44, "Open statement shadows an already defined identifier.";
    45, "Open statement shadows an already defined label or constructor.";
@@ -565,6 +582,7 @@ let descriptions =
    57, "Ambiguous or-pattern variables under guard";
    58, "Missing cmx file";
    59, "Assignment to non-mutable value";
+   60, "Unused module declaration";
   ]
 ;;
 
diff --git a/utils/warnings.mli b/utils/warnings.mli
index adb91a07..fb03935b 100644
--- a/utils/warnings.mli
+++ b/utils/warnings.mli
@@ -53,7 +53,7 @@ type t =
   | Unused_for_index of string              (* 35 *)
   | Unused_ancestor of string               (* 36 *)
   | Unused_constructor of string * bool * bool (* 37 *)
-  | Unused_extension of string * bool * bool   (* 38 *)
+  | Unused_extension of string * bool * bool * bool (* 38 *)
   | Unused_rec_flag                         (* 39 *)
   | Name_out_of_scope of string * string list * bool   (* 40 *)
   | Ambiguous_name of string list * string list * bool (* 41 *)
@@ -75,6 +75,8 @@ type t =
   | Ambiguous_pattern of string list        (* 57 *)
   | No_cmx_file of string                   (* 58 *)
   | Assignment_to_non_mutable_value         (* 59 *)
+  | Unused_module of string                 (* 60 *)
+  | Unboxable_type_in_prim_decl of string   (* 61 *)
 ;;
 
 val parse_options : bool -> string -> unit;;
diff --git a/yacc/Makefile b/yacc/Makefile
index 9713d41b..6c32474b 100644
--- a/yacc/Makefile
+++ b/yacc/Makefile
@@ -20,31 +20,32 @@ include ../config/Makefile
 CC=$(BYTECC)
 CFLAGS=-DNDEBUG $(BYTECCCOMPOPTS)
 
-OBJS= closure.o error.o lalr.o lr0.o main.o mkpar.o output.o reader.o \
-  skeleton.o symtab.o verbose.o warshall.o
+OBJS= closure.$(O) error.$(O) lalr.$(O) lr0.$(O) main.$(O) \
+  mkpar.$(O) output.$(O) reader.$(O) \
+  skeleton.$(O) symtab.$(O) verbose.$(O) warshall.$(O)
 
 all: ocamlyacc$(EXE)
 
 ocamlyacc$(EXE): $(OBJS)
-	$(CC) $(CFLAGS) $(CCLINKFLAGS) -o ocamlyacc$(EXE) $(OBJS)
+	$(MKEXE) -o ocamlyacc$(EXE) $(OBJS) $(EXTRALIBS)
 
 version.h : ../VERSION
 	echo "#define OCAML_VERSION \"`sed -e 1q ../VERSION`\"" >version.h
 
 clean:
-	rm -f *.o ocamlyacc$(EXE) *~ version.h
+	rm -f *.$(O) ocamlyacc$(EXE) *~ version.h
 
 depend:
 
-closure.o: defs.h
-error.o: defs.h
-lalr.o: defs.h
-lr0.o: defs.h
-main.o: defs.h version.h
-mkpar.o: defs.h
-output.o: defs.h
-reader.o: defs.h
-skeleton.o: defs.h
-symtab.o: defs.h
-verbose.o: defs.h
-warshall.o: defs.h
+closure.$(O): defs.h
+error.$(O): defs.h
+lalr.$(O): defs.h
+lr0.$(O): defs.h
+main.$(O): defs.h version.h
+mkpar.$(O): defs.h
+output.$(O): defs.h
+reader.$(O): defs.h
+skeleton.$(O): defs.h
+symtab.$(O): defs.h
+verbose.$(O): defs.h
+warshall.$(O): defs.h
diff --git a/yacc/Makefile.nt b/yacc/Makefile.nt
index 7c13f4c0..917f48bd 100644
--- a/yacc/Makefile.nt
+++ b/yacc/Makefile.nt
@@ -13,39 +13,7 @@
 #*                                                                        *
 #**************************************************************************
 
-# Makefile for the parser generator.
-
-include ../config/Makefile
-
-OBJS= closure.$(O) error.$(O) lalr.$(O) lr0.$(O) main.$(O) \
-  mkpar.$(O) output.$(O) reader.$(O) \
-  skeleton.$(O) symtab.$(O) verbose.$(O) warshall.$(O)
-
-all: ocamlyacc.exe
-
-ocamlyacc.exe: $(OBJS)
-	$(MKEXE) -o ocamlyacc.exe $(OBJS) $(EXTRALIBS)
-
-version.h : ../VERSION
-	echo "#define OCAML_VERSION \"`sed -e 1q ../VERSION`\"" >version.h
-
-clean:
-	rm -f *.$(O) ocamlyacc.exe *~ version.h
+include Makefile
 
 %.$(O): %.c
 	$(BYTECC) -DNDEBUG -DNO_UNIX $(BYTECCCOMPOPTS) -c $<
-
-depend:
-
-closure.$(O): defs.h
-error.$(O): defs.h
-lalr.$(O): defs.h
-lr0.$(O): defs.h
-main.$(O): defs.h version.h
-mkpar.$(O): defs.h
-output.$(O): defs.h
-reader.$(O): defs.h
-skeleton.$(O): defs.h
-symtab.$(O): defs.h
-verbose.$(O): defs.h
-warshall.$(O): defs.h
diff --git a/yacc/defs.h b/yacc/defs.h
index 41680765..8377d05d 100644
--- a/yacc/defs.h
+++ b/yacc/defs.h
@@ -210,6 +210,7 @@ extern char tflag;
 extern char vflag;
 extern char qflag;
 extern char sflag;
+extern char eflag;
 extern char big_endian;
 
 extern char *myname;
@@ -335,6 +336,7 @@ extern void output (void);
 extern void over_unionized (char *u_cptr) Noreturn;
 extern void prec_redeclared (void);
 extern void polymorphic_entry_point(char *s) Noreturn;
+extern void forbidden_conflicts (void);
 extern void reader (void);
 extern void reflexive_transitive_closure (unsigned int *R, int n);
 extern void reprec_warning (char *s);
diff --git a/yacc/error.c b/yacc/error.c
index 1b533a43..236908c0 100644
--- a/yacc/error.c
+++ b/yacc/error.c
@@ -313,3 +313,11 @@ void polymorphic_entry_point(char *s)
             myname, s);
     done(1);
 }
+
+void forbidden_conflicts(void)
+{
+    fprintf(stderr,
+            "%s: the grammar has conflicts, but --strict was specified\n",
+            myname);
+    done(1);
+}
diff --git a/yacc/main.c b/yacc/main.c
index 329d397f..e7606dae 100644
--- a/yacc/main.c
+++ b/yacc/main.c
@@ -30,6 +30,7 @@ char rflag;
 char tflag;
 char vflag;
 char qflag;
+char eflag;
 char sflag;
 char big_endian;
 
@@ -160,7 +161,7 @@ void set_signals(void)
 
 void usage(void)
 {
-    fprintf(stderr, "usage: %s [-v] [-q] [-b file_prefix] filename\n",
+    fprintf(stderr, "usage: %s [-v] [--strict] [-q] [-b file_prefix] filename\n",
             myname);
     exit(1);
 }
@@ -184,6 +185,10 @@ void getargs(int argc, char **argv)
             return;
 
         case '-':
+            if (!strcmp (argv[i], "--strict")){
+              eflag = 1;
+              goto end_of_option;
+            }
             ++i;
             goto no_more_options;
 
@@ -457,6 +462,7 @@ int main(int argc, char **argv)
     lalr();
     make_parser();
     verbose();
+    if (eflag && SRtotal + RRtotal > 0) forbidden_conflicts();
     output();
     done(0);
     /*NOTREACHED*/