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/targetint.cmo : utils/misc.cmi utils/targetint.cmi
+utils/targetint.cmx : utils/misc.cmx utils/targetint.cmi
+utils/targetint.cmi :
utils/tbl.cmo : utils/tbl.cmi
utils/tbl.cmx : utils/tbl.cmi
utils/tbl.cmi :
utils/warnings.cmo : utils/misc.cmi utils/warnings.cmi
utils/warnings.cmx : utils/misc.cmx utils/warnings.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.cmo : parsing/syntaxerr.cmi parsing/parsetree.cmi \
+ parsing/longident.cmi parsing/location.cmi parsing/docstrings.cmi \
+ parsing/asttypes.cmi parsing/ast_helper.cmi
+parsing/ast_helper.cmx : parsing/syntaxerr.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/asttypes.cmi
parsing/pprintast.cmo : parsing/parsetree.cmi utils/misc.cmi \
parsing/longident.cmi parsing/location.cmi parsing/asttypes.cmi \
- parsing/pprintast.cmi
+ parsing/ast_helper.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/ast_helper.cmx 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 \
typing/mtype.cmi utils/misc.cmi parsing/longident.cmi \
parsing/location.cmi typing/includemod.cmi typing/ident.cmi \
typing/env.cmi typing/ctype.cmi utils/config.cmi typing/cmt_format.cmi \
- utils/clflags.cmi parsing/builtin_attributes.cmi typing/btype.cmi \
- parsing/asttypes.cmi parsing/ast_iterator.cmi typing/annot.cmi \
- typing/typemod.cmi
+ typing/cmi_format.cmi utils/clflags.cmi parsing/builtin_attributes.cmi \
+ typing/btype.cmi parsing/asttypes.cmi parsing/ast_iterator.cmi \
+ typing/annot.cmi typing/typemod.cmi
typing/typemod.cmx : utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \
typing/typedtree.cmx typing/typedecl.cmx typing/typecore.cmx \
typing/typeclass.cmx typing/subst.cmx typing/stypes.cmx \
typing/mtype.cmx utils/misc.cmx parsing/longident.cmx \
parsing/location.cmx typing/includemod.cmx typing/ident.cmx \
typing/env.cmx typing/ctype.cmx utils/config.cmx typing/cmt_format.cmx \
- utils/clflags.cmx parsing/builtin_attributes.cmx typing/btype.cmx \
- parsing/asttypes.cmi parsing/ast_iterator.cmx typing/annot.cmi \
- typing/typemod.cmi
+ typing/cmi_format.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/env.cmi typing/cmi_format.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
bytecomp/bytesections.cmo : utils/config.cmi bytecomp/bytesections.cmi
bytecomp/bytesections.cmx : utils/config.cmx bytecomp/bytesections.cmi
bytecomp/bytesections.cmi :
-bytecomp/cmo_format.cmi : bytecomp/lambda.cmi typing/ident.cmi
+bytecomp/cmo_format.cmi : utils/tbl.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/runtimedef.cmo : bytecomp/runtimedef.cmi
bytecomp/runtimedef.cmx : bytecomp/runtimedef.cmi
bytecomp/runtimedef.cmi :
+bytecomp/semantics_of_primitives.cmo : bytecomp/lambda.cmi \
+ bytecomp/semantics_of_primitives.cmi
+bytecomp/semantics_of_primitives.cmx : bytecomp/lambda.cmx \
+ bytecomp/semantics_of_primitives.cmi
+bytecomp/semantics_of_primitives.cmi : bytecomp/lambda.cmi
bytecomp/simplif.cmo : utils/warnings.cmi 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 \
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/symtable.cmi : utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi \
bytecomp/cmo_format.cmi
bytecomp/translattribute.cmo : utils/warnings.cmi typing/typedtree.cmi \
parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \
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 \
- typing/parmatch.cmi utils/misc.cmi bytecomp/matching.cmi \
+ typing/typedtree.cmi typing/typecore.cmi bytecomp/translobj.cmi \
+ bytecomp/translattribute.cmi typing/primitive.cmi typing/predef.cmi \
+ typing/path.cmi typing/parmatch.cmi utils/misc.cmi bytecomp/matching.cmi \
parsing/longident.cmi parsing/location.cmi bytecomp/lambda.cmi \
typing/ident.cmi typing/env.cmi utils/config.cmi utils/clflags.cmi \
typing/btype.cmi parsing/asttypes.cmi bytecomp/translcore.cmi
bytecomp/translcore.cmx : typing/types.cmx bytecomp/typeopt.cmx \
- typing/typedtree.cmx bytecomp/translobj.cmx bytecomp/translattribute.cmx \
- typing/primitive.cmx typing/predef.cmx typing/path.cmx \
- typing/parmatch.cmx utils/misc.cmx bytecomp/matching.cmx \
+ typing/typedtree.cmx typing/typecore.cmx bytecomp/translobj.cmx \
+ bytecomp/translattribute.cmx typing/primitive.cmx typing/predef.cmx \
+ typing/path.cmx typing/parmatch.cmx utils/misc.cmx bytecomp/matching.cmx \
parsing/longident.cmx parsing/location.cmx bytecomp/lambda.cmx \
typing/ident.cmx typing/env.cmx utils/config.cmx utils/clflags.cmx \
typing/btype.cmx parsing/asttypes.cmi bytecomp/translcore.cmi
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/afl_instrument.cmo : bytecomp/lambda.cmi typing/ident.cmi \
+ middle_end/debuginfo.cmi asmcomp/cmm.cmi utils/clflags.cmi \
+ parsing/asttypes.cmi asmcomp/afl_instrument.cmi
+asmcomp/afl_instrument.cmx : bytecomp/lambda.cmx typing/ident.cmx \
+ middle_end/debuginfo.cmx asmcomp/cmm.cmx utils/clflags.cmx \
+ parsing/asttypes.cmi asmcomp/afl_instrument.cmi
+asmcomp/afl_instrument.cmi : asmcomp/cmm.cmi
+asmcomp/arch.cmo : utils/config.cmi utils/clflags.cmi
+asmcomp/arch.cmx : utils/config.cmx utils/clflags.cmx
asmcomp/asmgen.cmo : asmcomp/un_anf.cmi bytecomp/translmod.cmi \
utils/timings.cmi middle_end/base_types/symbol.cmi asmcomp/split.cmi \
asmcomp/spill.cmi asmcomp/selection.cmi asmcomp/scheduling.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/simplif.cmi bytecomp/semantics_of_primitives.cmi \
+ typing/primitive.cmi utils/misc.cmi parsing/location.cmi \
+ bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \
middle_end/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \
utils/clflags.cmi asmcomp/clambda.cmi 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/simplif.cmx bytecomp/semantics_of_primitives.cmx \
+ typing/primitive.cmx utils/misc.cmx parsing/location.cmx \
+ bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \
middle_end/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \
utils/clflags.cmx asmcomp/clambda.cmx parsing/asttypes.cmi \
asmcomp/arch.cmx asmcomp/closure.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 \
- middle_end/debuginfo.cmi asmcomp/arch.cmo asmcomp/cmm.cmi
+ middle_end/debuginfo.cmi parsing/asttypes.cmi asmcomp/arch.cmo \
+ asmcomp/cmm.cmi
asmcomp/cmm.cmx : bytecomp/lambda.cmx typing/ident.cmx \
- middle_end/debuginfo.cmx asmcomp/arch.cmx asmcomp/cmm.cmi
+ middle_end/debuginfo.cmx parsing/asttypes.cmi asmcomp/arch.cmx \
+ asmcomp/cmm.cmi
asmcomp/cmm.cmi : bytecomp/lambda.cmi typing/ident.cmi \
- middle_end/debuginfo.cmi
+ middle_end/debuginfo.cmi parsing/asttypes.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 \
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/afl_instrument.cmi 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 \
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/afl_instrument.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
typing/ident.cmi middle_end/flambda.cmi asmcomp/export_info.cmi \
typing/env.cmi utils/config.cmi \
middle_end/base_types/compilation_unit.cmi asmcomp/cmx_format.cmi \
- middle_end/base_types/closure_id.cmi asmcomp/clambda.cmi \
- asmcomp/compilenv.cmi
+ middle_end/base_types/closure_id.cmi utils/clflags.cmi \
+ asmcomp/clambda.cmi asmcomp/compilenv.cmi
asmcomp/compilenv.cmx : utils/warnings.cmx middle_end/base_types/symbol.cmx \
middle_end/base_types/set_of_closures_id.cmx utils/misc.cmx \
parsing/location.cmx middle_end/base_types/linkage_name.cmx \
typing/ident.cmx middle_end/flambda.cmx asmcomp/export_info.cmx \
typing/env.cmx utils/config.cmx \
middle_end/base_types/compilation_unit.cmx asmcomp/cmx_format.cmi \
- middle_end/base_types/closure_id.cmx asmcomp/clambda.cmx \
- asmcomp/compilenv.cmi
+ middle_end/base_types/closure_id.cmx utils/clflags.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 \
asmcomp/export_info_for_pack.cmo : middle_end/base_types/variable.cmi \
middle_end/base_types/var_within_closure.cmi \
middle_end/base_types/symbol.cmi \
+ middle_end/base_types/set_of_closures_origin.cmi \
middle_end/base_types/set_of_closures_id.cmi utils/misc.cmi \
middle_end/flambda_utils.cmi middle_end/flambda_iterators.cmi \
middle_end/flambda.cmi asmcomp/export_info.cmi \
asmcomp/export_info_for_pack.cmx : middle_end/base_types/variable.cmx \
middle_end/base_types/var_within_closure.cmx \
middle_end/base_types/symbol.cmx \
+ middle_end/base_types/set_of_closures_origin.cmx \
middle_end/base_types/set_of_closures_id.cmx utils/misc.cmx \
middle_end/flambda_utils.cmx middle_end/flambda_iterators.cmx \
middle_end/flambda.cmx asmcomp/export_info.cmx \
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/cmm.cmi asmcomp/interf.cmi
asmcomp/interf.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \
- asmcomp/interf.cmi
+ asmcomp/cmm.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 middle_end/debuginfo.cmi utils/config.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 utils/config.cmi \
- asmcomp/liveness.cmi
+ asmcomp/cmm.cmi asmcomp/liveness.cmi
asmcomp/liveness.cmx : asmcomp/reg.cmx asmcomp/proc.cmx \
asmcomp/printmach.cmx utils/misc.cmx asmcomp/mach.cmx utils/config.cmx \
- asmcomp/liveness.cmi
+ asmcomp/cmm.cmx asmcomp/liveness.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/printclambda.cmi
asmcomp/printclambda.cmi : asmcomp/clambda.cmi
asmcomp/printcmm.cmo : bytecomp/lambda.cmi typing/ident.cmi \
- middle_end/debuginfo.cmi asmcomp/cmm.cmi asmcomp/printcmm.cmi
+ middle_end/debuginfo.cmi asmcomp/cmm.cmi parsing/asttypes.cmi \
+ asmcomp/printcmm.cmi
asmcomp/printcmm.cmx : bytecomp/lambda.cmx typing/ident.cmx \
- middle_end/debuginfo.cmx asmcomp/cmm.cmx asmcomp/printcmm.cmi
-asmcomp/printcmm.cmi : asmcomp/cmm.cmi
+ middle_end/debuginfo.cmx asmcomp/cmm.cmx parsing/asttypes.cmi \
+ asmcomp/printcmm.cmi
+asmcomp/printcmm.cmi : middle_end/debuginfo.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/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/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo 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/cmm.cmx utils/clflags.cmx asmcomp/arch.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/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 middle_end/debuginfo.cmi utils/config.cmi \
- asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/selectgen.cmi
+ asmcomp/cmm.cmi parsing/asttypes.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 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/cmm.cmx parsing/asttypes.cmi asmcomp/arch.cmx \
+ asmcomp/selectgen.cmi
+asmcomp/selectgen.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/selectgen.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/selectgen.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.cmo : 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 \
+ parsing/asttypes.cmi asmcomp/arch.cmo asmcomp/spacetime_profiling.cmi
+asmcomp/spacetime_profiling.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 \
+ parsing/asttypes.cmi 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/mach.cmi asmcomp/cmm.cmi asmcomp/spill.cmi
asmcomp/spill.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
- asmcomp/mach.cmx asmcomp/spill.cmi
+ asmcomp/mach.cmx asmcomp/cmm.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/strmatch.cmo : bytecomp/lambda.cmi typing/ident.cmi \
+ middle_end/debuginfo.cmi asmcomp/cmm.cmi parsing/asttypes.cmi \
asmcomp/arch.cmo asmcomp/strmatch.cmi
-asmcomp/strmatch.cmx : bytecomp/lambda.cmx typing/ident.cmx asmcomp/cmm.cmx \
+asmcomp/strmatch.cmx : bytecomp/lambda.cmx typing/ident.cmx \
+ middle_end/debuginfo.cmx asmcomp/cmm.cmx parsing/asttypes.cmi \
asmcomp/arch.cmx asmcomp/strmatch.cmi
-asmcomp/strmatch.cmi : asmcomp/cmm.cmi
-asmcomp/un_anf.cmo : middle_end/semantics_of_primitives.cmi \
+asmcomp/strmatch.cmi : middle_end/debuginfo.cmi asmcomp/cmm.cmi
+asmcomp/un_anf.cmo : bytecomp/semantics_of_primitives.cmi \
asmcomp/printclambda.cmi utils/misc.cmi bytecomp/lambda.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/un_anf.cmx : bytecomp/semantics_of_primitives.cmx \
asmcomp/printclambda.cmx utils/misc.cmx bytecomp/lambda.cmx \
typing/ident.cmx middle_end/debuginfo.cmx utils/clflags.cmx \
asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/un_anf.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 \
- bytecomp/printlambda.cmi typing/primitive.cmi typing/predef.cmi \
- utils/numbers.cmi middle_end/base_types/mutable_variable.cmi \
- utils/misc.cmi parsing/location.cmi \
- middle_end/base_types/linkage_name.cmi middle_end/lift_code.cmi \
- bytecomp/lambda.cmi typing/ident.cmi middle_end/flambda_utils.cmi \
- middle_end/flambda.cmi middle_end/debuginfo.cmi utils/config.cmi \
+ bytecomp/printlambda.cmi typing/predef.cmi utils/numbers.cmi \
+ middle_end/base_types/mutable_variable.cmi utils/misc.cmi \
+ parsing/location.cmi middle_end/base_types/linkage_name.cmi \
+ middle_end/lift_code.cmi bytecomp/lambda.cmi typing/ident.cmi \
+ middle_end/flambda_utils.cmi middle_end/flambda.cmi \
+ 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/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 \
- bytecomp/printlambda.cmx typing/primitive.cmx typing/predef.cmx \
- utils/numbers.cmx middle_end/base_types/mutable_variable.cmx \
- utils/misc.cmx parsing/location.cmx \
- middle_end/base_types/linkage_name.cmx middle_end/lift_code.cmx \
- bytecomp/lambda.cmx typing/ident.cmx middle_end/flambda_utils.cmx \
- middle_end/flambda.cmx middle_end/debuginfo.cmx utils/config.cmx \
+ bytecomp/printlambda.cmx typing/predef.cmx utils/numbers.cmx \
+ middle_end/base_types/mutable_variable.cmx utils/misc.cmx \
+ parsing/location.cmx middle_end/base_types/linkage_name.cmx \
+ middle_end/lift_code.cmx bytecomp/lambda.cmx typing/ident.cmx \
+ middle_end/flambda_utils.cmx middle_end/flambda.cmx \
+ 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/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 parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \
+ middle_end/base_types/static_exception.cmi utils/numbers.cmi \
+ middle_end/base_types/mutable_variable.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 parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \
+ middle_end/base_types/static_exception.cmx utils/numbers.cmx \
+ middle_end/base_types/mutable_variable.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/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 \
+middle_end/effect_analysis.cmo : bytecomp/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 \
+middle_end/effect_analysis.cmx : bytecomp/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/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/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 bytecomp/lambda.cmi middle_end/inlining_cost.cmi \
+ middle_end/base_types/set_of_closures_id.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/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 bytecomp/lambda.cmx middle_end/inlining_cost.cmx \
+ middle_end/base_types/set_of_closures_id.cmx 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/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/set_of_closures_id.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/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 middle_end/semantics_of_primitives.cmi \
+ middle_end/simple_value_approx.cmi bytecomp/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 middle_end/semantics_of_primitives.cmx \
+ middle_end/simple_value_approx.cmx bytecomp/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
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 \
+driver/compmisc.cmo : utils/warnings.cmi 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 \
parsing/asttypes.cmi driver/compmisc.cmi
-driver/compmisc.cmx : typing/typemod.cmx utils/misc.cmx \
+driver/compmisc.cmx : utils/warnings.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
*.png binary
*.tfm binary
+# 'union' merge driver just unions textual content in case of conflict
+# http://krlmlr.github.io/using-gitattributes-to-avoid-merge-conflicts/
+/.mailmap merge=union
+/Changes merge=union
+
# No header for text files (would be too obtrusive).
*.md ocaml-typo=missing-header
README* ocaml-typo=missing-header
# Similarly, the docstring tests fail for the same reason on Windows
testsuite/tests/docstrings/empty.ml text eol=lf
+
+# And w04.ml
+testsuite/tests/warnings/w04.ml text eol=lf
+
+# These are forced to \n to allow the Cygwin testsuite to pass on a
+# Windows-checkout
+testsuite/tests/formatting/margins.ml text eol=lf
+testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml text eol=lf
+testsuite/tests/typing-extension-constructor/test.ml text eol=lf
+testsuite/tests/typing-extensions/extensions.ml text eol=lf
+testsuite/tests/typing-extensions/open_types.ml text eol=lf
+testsuite/tests/typing-objects/Exemples.ml text eol=lf
+testsuite/tests/typing-objects/pr5619_bad.ml text eol=lf
+testsuite/tests/typing-objects/pr6123_bad.ml text eol=lf
+testsuite/tests/typing-objects/pr6907_bad.ml text eol=lf
+testsuite/tests/typing-objects/Tests.ml text eol=lf
+testsuite/tests/typing-pattern_open/pattern_open.ml text eol=lf
+testsuite/tests/typing-private/private.ml text eol=lf
+testsuite/tests/typing-recordarg/recordarg.ml text eol=lf
+testsuite/tests/typing-short-paths/pr5918.ml text eol=lf
+testsuite/tests/typing-sigsubst/sigsubst.ml text eol=lf
+testsuite/tests/typing-typeparam/newtype.ml text eol=lf
+testsuite/tests/typing-unboxed/test.ml text eol=lf
+testsuite/tests/typing-unboxed-types/test.ml text eol=lf
+testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml text eol=lf
+testsuite/tests/typing-warnings/coercions.ml text eol=lf
+testsuite/tests/typing-warnings/exhaustiveness.ml text eol=lf
+testsuite/tests/typing-warnings/pr6872.ml text eol=lf
+testsuite/tests/typing-warnings/pr7085.ml text eol=lf
+testsuite/tests/typing-warnings/pr7115.ml text eol=lf
+testsuite/tests/typing-warnings/records.ml text eol=lf
+testsuite/tests/typing-warnings/unused_types.ml text eol=lf
/asmrun/*.p.c
/asmrun/*.d.c
/asmrun/alloc.c
+/asmrun/afl.c
/asmrun/array.c
/asmrun/backtrace.c
/asmrun/callback.c
/asmrun/terminfo.c
/asmrun/unix.c
/asmrun/weak.c
+/asmrun/win32.c
/boot/Saved
/boot/ocamlrun
/config/m.h
/config/s.h
/config/Makefile
+/config/auto-aux/hashbang4
/debugger/lexer.ml
/debugger/parser.ml
/tools/cmpbyt.opt
/tools/stripdebug
/tools/stripdebug.opt
+/tools/make_opcodes
+/tools/make_opcodes.ml
/utils/config.ml
#
# Preferred Name <email> nickname <contribution-email>
# or
-# Preferred Name <nickname@mantis.com>
-# Preferred Name <nickname>@github.com
+# Preferred Name <nickname@mantis>
+# Preferred Name <nickname@github>
# to indicate a preference associated to a Mantis account.
Florian Angeletti <octa@polychoron.fr> octachron <octa@polychoron.fr>
Frederic Bour <frederic.bour@lakaban.net> <def@mantis>
David Sheets <dsheets@mantis>
David Allsopp <dra@mantis>
+David Allsopp <dra27@github>
Tim Cuthbertson <gfxmonk@mantis>
Grégoire Henry <hnrgrgr@mantis>
Julien Moutinho <julm@mantis>
David Scott <djs55>
Martin Neuhäußer <sawfish@mantis>
Goswin von Brederlow <mrvn>
+Thomas Leonard <talex@mantis>
+Thomas Leonard <talex5@github>
+Adrien Nader <adrien-n@github>
+Sébastien Hinderer <shindere@github>
+Gabriel Scherer <gasche@github>
+Immanuel Litzroth <sdev@mantis>
+Jacques Le Normand <rathereasy@github>
# These contributors prefer to be referred to pseudonymously
<whitequark@mantis> <whitequark@mantis>
BuildAndTest () {
case $XARCH in
i386)
- echo<<EOF
+ cat<<EOF
------------------------------------------------------------------------
This test builds the OCaml compiler distribution with your pull request,
runs its testsuite, and then tries to install some important OCaml software
export PATH=$PREFIX/bin:$PATH
make world.opt
make ocamlnat
- make install
(cd testsuite && make all)
(cd testsuite && make USE_RUNTIME="d" all)
+ make install
# check_all_arches checks tries to compile all backends in place,
# we need to redo (small parts of) world.opt afterwards
make check_all_arches
make world.opt
+ make manual-pregen
mkdir external-packages
cd external-packages
git clone git://github.com/ocaml/ocamlbuild
OCAML_NATIVE_TOOLS=true &&
make all &&
make install)
- git clone git://github.com/ocaml/camlp4 -b 4.04
+ git clone git://github.com/ocaml/camlp4 -b 4.05
(cd camlp4 &&
./configure --bindir=$PREFIX/bin --libdir=$PREFIX/lib/ocaml \
--pkgdir=$PREFIX/lib/ocaml && \
}
CheckChangesModified () {
- echo<<EOF
+ cat<<EOF
------------------------------------------------------------------------
This test checks that the Changes file has been modified by the pull
request. Most contributions should come with a message in the Changes
https://github.com/ocaml/ocaml/blob/trunk/CONTRIBUTING.md#changelog
Some very minor changes (typo fixes for example) may not need
-a Changes entry, in which case it is acceptable for this test to fail.
+a Changes entry. In this case, you may explicitly disable this test by
+adding the code word "No change entry needed" (on a single line) to
+a commit message of the PR, or using the "no-change-entry-needed" label
+on the github pull request.
------------------------------------------------------------------------
EOF
# check that Changes has been modified
git diff $TRAVIS_COMMIT_RANGE --name-only --exit-code Changes > /dev/null \
- && exit 1 || echo pass
+ && CheckNoChangesMessage || echo pass
+}
+
+CheckNoChangesMessage () {
+ if test -n "$(git log --grep="[Nn]o [Cc]hange.* needed" --max-count=1 $TRAVIS_COMMIT_RANGE)"
+ then echo pass
+ elif test -n "$(curl https://api.github.com/repos/$TRAVIS_REPO_SLUG/issues/$TRAVIS_PULL_REQUEST/labels \
+ | grep 'no-change-entry-needed')"
+ then echo pass
+ else exit 1
+ fi
}
CheckTestsuiteModified () {
- echo<<EOF
+ cat<<EOF
------------------------------------------------------------------------
This test checks that the OCaml testsuite has been modified by the
pull request. Any new feature should come with tests, bugs should come
case $CI_KIND in
build) BuildAndTest;;
-changes) CheckChangesModified;;
-tests) CheckTestsuiteModified;;
+changes)
+ case $TRAVIS_EVENT_TYPE in
+ pull_request) CheckChangesModified;;
+ esac;;
+tests)
+ case $TRAVIS_EVENT_TYPE in
+ pull_request) CheckTestsuiteModified;;
+ esac;;
*) echo unknown CI kind
exit 1
;;
matrix:
include:
- env: CI_KIND=build XARCH=i386
- - env: CI_KIND=build XARCH=i386 CONFIG_ARG=-flambda
+ - env: CI_KIND=build XARCH=i386 CONFIG_ARG=-flambda OCAMLRUNPARAM=b,v=0
- env: CI_KIND=changes
- env: CI_KIND=tests
allow_failures:
- - env: CI_KIND=changes
- env: CI_KIND=tests
best judgment and feel free to propose changes to this document itself
in a pull request.
+This document assumes that you have a patch against the sources of the
+compiler distribution, that you wish to submit to the OCaml
+maintainers upstream. See [INSTALL.adoc](INSTALL.adoc) for details on
+how to build the compiler distribution from sources. See
+[HACKING.adoc](HACKING.adoc) for details on how to modify the sources.
+
## Contribution
-Adding or modifying code is far from the only way to contribute to the
+Modifying its sources is far from the only way to contribute to the
OCaml distribution. Bug reports (in particular when they come with
a reproducible example), simple typos or clarifications in the
documentation also help, and help evaluating and integrating existing
existing documentations, also help. We currently have more
contributors willing to propose changes than contributors willing to
review other people's changes, so more eyes on the existing change
-requests is a good way to increase the integration bandwidth of external
-contributions.
+requests is a good way to increase the integration bandwidth of
+external contributions.
There are also many valuable ways to contribute to the wider OCaml
ecosystem that do not involve changes to the OCaml distribution.
### Changelog
-Any user-visible change should have a Changelog entry:
+Any user-visible change should have a `Changes` entry:
- in the right section (named sections if major feature, generic
"Bug fixes" and "Feature requests" otherwise)
(several numbers separated by commas can be used)
- maintaining the order: each section lists Mantis PRs first in ascending
- numerical order, followed by Github PRs
+ numerical order, followed by Github PRs in ascending numerical order,
+ followed by changes that are not related to a PR.
- with a concise readable description of the change (possibly taken
from a commit message, but it should make sense to end-users
-OCaml 4.04.0:
--------------
+OCaml 4.05.0 (TBD):
+----------------------------
+
+(Changes that can break existing programs are marked with a "*")
+
+### Language features:
+
+### Code generation and optimizations:
+
+- MPR#7201, GPR#954: Correct wrong optimisation of "0 / <expr>"
+ and "0 mod <expr>" in the case when <expr> was a non-constant
+ evaluating to zero
+ (Mark Shinwell)
+
+- MPR#7357, GPR#832: Improve compilation time for toplevel
+ include(struct ... end : sig ... end)
+ (Alain Frisch, report by Hongbo Zhang, review by Jacques Garrigue)
+
+- GPR#504: Instrumentation support for fuzzing with afl-fuzz.
+ (Stephen Dolan, review by Alain Frisch, Pierre Chambart, Mark
+ Shinwell, Gabriel Scherer and Damien Doligez)
+
+- GPR#863, GPR#1068, GPR#1069: Optimise matches with constant
+ results to lookup tables.
+ (Stephen Dolan, review by Gabriel Scherer, Pierre Chambart,
+ Mark Shinwell, and bug report by Gabriel Scherer)
+
+- GPR#1150: Fix typo in arm64 assembler directives
+ (KC Sivaramakrishnan)
+
+- PR#7533, GPR#1173: Correctly perform side effects for certain
+ cases of "/" and "mod"
+ (Mark Shinwell, report by Jan Mitgaard)
+
+### Runtime system:
+
+- MPR#385, GPR#953: Add caml_startup_exn
+ (Mark Shinwell)
+
+- PR#7423, GPR#946: expose new exception-raising functions
+ `void caml_{failwith,invalid_argument}_value(value msg)`
+ in addition to
+ `void caml_{failwith,invalid_argument}(char const *msg)`.
+ The previous functions would not free their message argument, so
+ were inconvient for dynamically-allocated messages; the messages
+ passed to the new functions are handled by the garbage collector.
+ (Gabriel Scherer, review by Mark Shinwell, request by Immanuel Litzroth)
+
+- PR#7557, GPR#1213: More security for getenv
+ (Damien Doligez, reports by Seth Arnold and Eric Milliken, review by
+ Xavier Leroy, David Allsopp, Stephen Dolan, Hannes Mehnert)
+
+- GPR#795: remove 256-character limitation on Sys.executable_name
+ (Xavier Leroy)
+
+- GPR#891: Use -fno-builtin-memcmp when building runtime with gcc.
+ (Leo White)
+
+### Type system:
+
+- PR#6608, GPR#901: unify record types when overriding all fields
+ (Tadeu Zagallo and Gabriel Scherer, report by Jeremy Yallop,
+ review by David Allsopp, Jacques Garrigue)
+
+* PR#7414, GPR#929: Soundness bug with non-generalized type variables and
+ functors.
+ (Jacques Garrigue, report by Leo White)
+
+### Compiler user-interface and warnings:
+
+- PR#7050, GPR#748 GPR#843 GPR#864: new `-args/-args0 <file>` parameters to
+ provide extra command-line arguments in a file -- see documentation.
+ User programs may implement similar options using the new `Expand`
+ constructor of the `Arg` module.
+ (Bernhard Schommer, review by Jérémie Dimino, Gabriel Scherer
+ and Damien Doligez, discussion with Alain Frisch and Xavier Leroy,
+ feature request from the Coq team)
+
+- PR#7137, GPR#960: "-open" command line flag now accepts a module path
+ (not a module name) (Arseniy Alekseyev and Leo White)
+
+- PR#7172, GPR#970: add extra (ocamlc -config) options
+ int_size, word_size, ext_exe
+ (Gabriel Scherer, request by Daniel Bünzli)
+
+- PR#7315, GPR#736: refine some error locations
+ (Gabriel Scherer and Alain Frisch, report by Matej Košík)
+
+- PR#7473, GPR#1025: perform proper globbing for command-line arguments on
+ Windows
+ (Jonathan Protzenko)
+
+- PR#7479: make sure "ocamlc -pack" is only given .cmo and .cmi files,
+ and that "ocamlopt -pack" is only given .cmx and .cmi files.
+ (Xavier Leroy)
+
+- GPR#796: allow compiler plugins to declare their own arguments.
+ (Fabrice Le Fessant)
+
+- GPR#829: better error when opening a module aliased to a functor
+ (Alain Frisch)
+
+- GPR#911: ocamlc/ocamlopt do not pass warnings-related options to C
+ compiler when called to compile third-party C source files
+ (Sébastien Hinderer)
+
+- GPR#915: fix -dsource (pprintast.ml) bugs
+ (Runhang Li, review by Alain Frisch)
+
+* GPR#933: ocamlopt -p now reports an error on platforms that do not
+ support profiling with gprof; dummy profiling libraries are no longer
+ installed on such platforms.
+ This can be tested with ocamlopt -config
+ (Sébastien Hinderer)
+
+- GPR#1009: "ocamlc -c -linkall" and "ocamlopt -c -linkall" can now be used
+ to set the "always link" flag on individual compilation units. This
+ controls linking with finer granularity than "-a -linkall", which sets
+ the "always link" flag on all units of the given library.
+ (Xavier Leroy)
+
+- GPR#1015: add option "-plugin PLUGIN" to ocamldep too. Use compilerlibs
+ to build ocamldep.
+ (Fabrice Le Fessant)
+
+- GPR#1027: various improvements to -dtimings, mostly including time
+ spent in subprocesses like preprocessors
+ (Valentin Gatien-Baron, review by Gabriel Scherer)
+
+- GPR#1098: the compiler now takes the boolean "OCAML_COLOR" environment
+ variable into account if "-color" is not provided. This allows users
+ to override the default behaviour without modifying invocations of ocaml
+ manually.
+ (Hannes Mehnert, Guillaume Bury,
+ review by Daniel Bünzli, Gabriel Scherer, Damien Doligez)
+
+### Standard library:
+
+- PR#6975, GPR#902: Truncate function added to stdlib Buffer module
+ (Dhruv Makwana, review by Alain Frisch and Gabriel Scherer)
+
+- PR#7279 GPR#710: `Weak.get_copy` `Ephemeron.*_copy` doesn't copy
+ custom blocks anymore
+ (François Bobot, Alain Frisch, bug reported by Martin R. Neuhäußer,
+ review by Thomas Braibant and Damien Doligez)
+
+* PR#7500, GPR#1081: Remove Uchar.dump
+ (Daniel Bünzli)
+
+- GPR#760: Add a functions List.compare_lengths and
+ List.compare_length_with to avoid full list length computations
+ (Fabrice Le Fessant)
+
+- GPR#778: Arg: added option Expand that allows to expand a string
+ argument to a string array of new arguments
+ (Bernhard Schommer)
+
+- GPR#849: Exposed Spacetime.enabled value
+ (Leo White)
+
+- GPR#885: Option-returning variants of stdlib functions
+ (Alain Frisch, review by David Allsopp and Bart Jacobs)
+
+- GPR#869: Add find_first, find_first_opt, find_last, find_last_opt to
+ maps and sets. Find the first or last binding or element
+ satisfying a monotonic predicate.
+ (Gabriel de Perthuis, with contributions from Alain Frisch, review by
+ Hezekiah M. Carty and Simon Cruanes, initial report by Gerd Stolpmann)
+
+- GPR#875: Add missing functions to ArrayLabels, BytesLabels,
+ ListLabels, MoreLabels, StringLabels so they are compatible with
+ non-labeled counterparts.
+ (Roma Sokolov)
+
+- GPR#999: Arg, do not repeat thrice usage_msg when reporting an error
+ (Florian Angeletti, review by Gabriel Scherer)
+
+- GPR#1042: Fix escaping of command-line arguments in
+ Unix.create_process{,_env} under Windows. Arguments with tabs should now
+ be received verbatim by the child process.
+ (Nicolas Ojeda Bar, Andreas Hauptmann review by Xavier Leroy)
+
+### Debugging and profiling:
+
+- PR#7258: ocamldebug's "install_printer" command had problems with
+ module aliases
+ (Xavier Leroy)
+
+- GPR#378: Add [Printexc.raise_with_backtrace] to raise an exception using
+ an explicit backtrace
+ (François Bobot, review by Gabriel Scherer, Xavier Leroy, Damien Doligez,
+ Frédéric Bour)
+
+### Manual and documentation:
+
+- PR#6597, GPR#1030: add forward references to language extensions
+ that extend non-terminal symbols in the language reference section.
+ (Florian Angeletti, review by Gabriel Scherer)
+
+- PR#7497, GPR#1095: manual, enable numbering for table of contents
+ (Florian Angeletti, request by Daniel Bünzli)
+
+- PR#7539, GPR#1181: manual, update dead links in ocamldoc chapter
+ (Florian Angeletti)
+
+- GPR#633: manpage and manual documentation for the `-opaque` option
+ (Konstantin Romanov, Gabriel Scherer, review by Mark Shinwell)
+
+- GPR#916: new tool lintapidiff, use it to update the manual with
+ @since annotations for API changes introduced between 4.00-4.05.
+ (Edwin Török, review by Gabriel Scherer, discussion with Alain Frisch,
+ David Allsopp, Sébastien Hinderer, Damien Doligez and Xavier Leroy)
+
+- GPR#939: activate the caml_example environment in the language
+ extensions section of the manual. Convert some existing code
+ examples to this format.
+ (Florian Angeletti)
+
+- GPR#1082: clarify that the use of quoted string for preprocessed
+ foreign quotations still requires the use of an extension node
+ [%foo ...] to mark non-standard interpretation.
+ (Gabriel Scherer, request by Matthew Wahab in GPR#1066,
+ review by Florian Angeletti)
+
+- add a HACKING.adoc file to contain various tips and tricks for
+ people hacking on the repository. See also CONTRIBUTING.md for
+ advice on sending contributions upstream.
+ (Gabriel Scherer and Gabriel Radanne, review by David Allsopp,
+ inspired by John Whitington)
+
+### Other libraries:
+
+- PR#7158: Event.sync, Mutex.create, Condition.create cause too many GCs.
+ The fix is to no longer consider mutexes and condition variables
+ as rare kernel resources.
+ (Xavier Leroy)
+
+- PR#7264: document the different behaviors of Unix.lockf under POSIX
+ and under Win32.
+ (Xavier Leroy, report by David Allsopp)
+
+- MPR#7339, GPR#787: Support the '0 dimension' case for bigarrays
+ (see Bigarray documentation)
+ (Laurent Mazare,
+ review by Gabriel Scherer, Alain Frisch and Hezekiah M. Carty)
+
+* PR#7342, GPR#797: fix Unix.read on pipes with no data left on Windows
+ it previously raised an EPIPE error, it now returns 0 like other OSes
+ (Jonathan Protzenko)
+
+- GPR#650: in the Unix library, add `?cloexec:bool` optional arguments to
+ functions that create file descriptors (`dup`, `dup2`, `pipe`, `socket`,
+ `socketpair`, `accept`). Implement these optional arguments in the
+ most atomic manner provided by the operating system to set (or clear)
+ the close-on-exec flag at the same time the file descriptor is created,
+ reducing the risk of race conditions with `exec` or `create_process`
+ calls running in other threads, and improving security. Also: add a
+ `O_KEEPEXEC` flag for `openfile` by symmetry with `O_CLOEXEC`.
+ (Xavier Leroy)
+
+- GPR#996: correctly update caml_top_of_stack in systhreads
+ (Fabrice Le Fessant)
+
+### Toplevel:
+
+- PR#7060, GPR#1035: Print exceptions in installed custom printers
+ (Tadeu Zagallo, review by David Allsopp)
+
+### Tools:
+
+- PR#5163: ocamlobjinfo, dump globals defined by bytecode executables
+ (Stéphane Glondu)
+
+- PR#7333: ocamldoc, use the first sentence of text file as
+ a short description in overviews.
+ (Florian Angeletti)
+
+- GPR#848: ocamldoc, escape link targets in HTML output
+ (Etienne Millon, review by Gabriel Scherer, Florian Angeletti and
+ Daniel Bünzli)
+
+- GPR#986: ocamldoc, use relative paths in error message
+ to solve ocamlbuild+doc usability issue (ocaml/ocamlbuild#79)
+ (Gabriel Scherer, review by Florian Angeletti, discussion with Daniel Bünzli)
+
+- GPR#1017: ocamldoc, add an option to detect code fragments that could be
+ transformed into a cross-reference to a known element.
+ (Florian Angeletti, review and suggestion by David Allsopp)
+
+- clarify ocamldoc text parsing error messages
+ (Gabriel Scherer)
+
+### Compiler distribution build system:
+
+- PR#7377: remove -std=gnu99 for newer gcc versions
+ (Damien Doligez, report by ygrek)
+
+- GPR#693: fail on unexpected errors or warnings within caml_example
+ environment.
+ (Florian Angeletti)
+
+- GPR#803: new ocamllex-based tool to extract bytecode compiler
+ opcode information from C headers.
+ (Nicolas Ojeda Bar)
+
+- GPR#827: install missing mli and cmti files, new make target
+ install-compiler-sources for installation of compiler-libs ml files
+ (Hendrik Tews)
+
+- GPR#887: allow -with-frame-pointers if clang is used as compiler on Linux
+ (Bernhard Schommer)
+
+- GPR#898: fix locale-dependence of primitive list order,
+ detected through reproducible-builds.org.
+ (Hannes Mehnert, review by Gabriel Scherer and Ximin Luo)
+
+- GPR#907: Remove unused variable from the build system
+ (Sébastien Hinderer, review by whitequark, Gabriel Scherer, Adrien Nader)
+
+- GPR#911: Clarify the use of C compiler related variables in the build system.
+ (Sébastien Hinderer, review by Adrien Nader, Alain Frisch, David Allsopp)
+
+- GPR#919: use clang as preprocessor assembler if clang is used as compiler
+ (Bernhard Schommer)
+
+- GPR#927: improve the detection of hashbang support in the configure script
+ (Armaël Guéneau)
+
+- GPR#932: install ocaml{c,lex}->ocaml{c,lex}.byte symlink correctly
+ when the opt target is built but opt.opt target is not.
+ (whitequark)
+
+- GPR#935: allow build in Android's termux
+ (ygrek, review by Gabriel Scherer)
+
+- GPR#984: Fix compilation of compiler distribution when Spacetime
+ enabled
+ (Mark Shinwell)
+
+- GPR#991: On Windows, fix installation when native compiler is not
+ built
+ (Sébastien Hinderer, review by David Allsopp)
+
+- GPR#1033: merge Unix and Windows build systems in the root directory
+ (Sébastien Hinderer, review by Damien Doligez and Adrien Nader)
+
+- GPR#1047: Make .depend files generated for C sources more portable
+ (Sébastien Hinderer, review by Xavier Leroy and David Allsopp)
+
+- GPR#1076: Simplify ocamlyacc's build system
+ (Sébastien Hinderer, review by David Allsopp)
+
+### Compiler distribution build system: Makefile factorization
+
+The compiler distribution build system (the set of Makefiles used to
+build the compiler distribution) traditionally had separate Makefiles
+for Unix and Windows, which lead to some amount of duplication and
+subtle differences and technical debt in general -- for people working
+on the compiler distribution, but also cross-compilation or porting to
+new systems. During the 4.05 development period, Sébastien Hinderer
+worked on harmonizing the build rules and merging the two build
+systems.
+
+* Some changes were made to the config/Makefile file which
+ is exported as $(ocamlc -where)/Makefile.config, and on
+ which some advanced users might rely. The changes are
+ as follows:
+ - a BYTERUN variable was added that points to the installed ocamlrun
+ - the PARTIALLD variable was removed (PACKLD is more complete)
+ - the always-empty DLLCCCOMPOPTS was removed
+ - the SHARED variable was removed; its value is "shared" or "noshared",
+ which duplicates the existing and more convenient
+ SUPPORTS_SHARED_LIBRARIES variable whose value is "true" or "false".
+
+ Note that Makefile.config may change further in the future and relying
+ on it is a bit fragile. We plan to make `ocamlc -config` easier to use
+ for scripting purposes, and have a stable interface there. If you rely
+ on Makefile.config, you may want to get in touch with Sébastien Hinderer
+ or participate to MPR#7116 (Allow easy retrieval of Makefile.config's values)
+ or MPR#7172 (More information in ocamlc -config).
+
+The complete list of changes is listed below.
+
+- GPR#705: update Makefile.nt so that ocamlnat compiles
+ for non-Cygwin Windows ports.
+ (Sébastien Hinderer, review by Alain Frisch)
+
+- GPR#729: Make sure ocamlnat is built with a $(EXE) extension, merge
+ rules between Unix and Windows Makefiles
+ (Sébastien Hinderer, review by Alain Frisch)
+
+- GPR#762: Merge build systems in the yacc/ directory.
+ (Sébastien Hinderer, review by David Allsopp, Alain Frisch)
+
+- GPR#764: Merge build systems in the debugger/ directory.
+ (Sébastien Hinderer, review by Alain Frisch)
+
+- GPR#785: Merge build systems in otherlibs/systhreads/
+ (Sébastien Hinderer, review by Alain Frisch, David Allsopp,
+ testing and regression fix by Jérémie Dimino)
+
+- GPR#788: Merge build systems in subdirectories of otherlibs/.
+ (Sébastien Hinderer, review by Alain Frisch)
+
+- GPR#808, GPR#906: Merge Unix and Windows build systems
+ in the ocamldoc/ directory
+ (Sébastien Hinderer, review by Alain Frisch)
+
+- GPR#812: Merge build systems in the tools/ subdirectory
+ (Sébastien Hinderer, review by Alain Frisch)
+
+- GPR#866: Merge build systems in the stdlib/ directory
+ (Sébastien Hinderer, review by David Allsopp and Adrien Nader)
+
+- GPR#941: Merge Unix and Windows build systems in the asmrun/ directory
+ (Sébastien Hinderer, review by Mark Shinwell, Adrien Nader,
+ Xavier Leroy, David Allsopp, Damien Doligez)
+
+- GPR#981: Merge build systems in the byterun/ directory
+ (Sébastien Hinderer, review by Adrien Nader)
+
+- GPR#1033, GPR#1048: Merge build systems in the root directory
+ (Sébastien Hinderer, review by Adrien Nader and Damien Doligez,
+ testing and regression fix by Andreas Hauptmann)
+
+### Internal/compiler-libs changes:
+
+- GPR#673: distinguish initialization of block fields from mutation in lambda.
+ (Frédéric Bour, review by Xavier Leroy, Stephen Dolan and Mark Shinwell)
+
+- GPR#744, GPR#781: fix duplicate self-reference in imported cmi_crcs
+ list in .cmti files + avoid rebuilding cmi_info record when creating
+ .cmti files
+ (Alain Frisch, report by Daniel Bünzli, review by Jérémie Dimino)
+
+- GPR#881: change `Outcometree.out_variant` to be more general.
+ `Ovar_name of out_ident * out_type list` becomes `Ovar_type of out_type`.
+ (Valentin Gatien-Baron)
+
+- GPR#908: refactor PIC-handling in the s390x backend
+ (Gabriel Scherer)
+
+### Bug fixes
+
+- PR#5115: protect all byterun/fail.c functions against
+ uninitialized caml_global_data (only changes the bytecode behavior)
+ (Gabriel Scherer, review by Xavier Leroy)
+
+- PR#6136, GPR#967: Fix Closure so that overapplication evaluation order
+ matches the bytecode compiler and Flambda.
+ (Mark Shinwell, report by Jeremy Yallop, review by Frédéric Bour)
+
+- PR#6550, GPR#1094: Allow creation of empty .cmxa files on macOS
+ (Mark Shinwell)
+
+- PR#6594, GPR#955: Remove "Istore_symbol" specific operation on x86-64.
+ This is more robust and in particular avoids assembly failures on Win64.
+ (Mark Shinwell, review by Xavier Leroy, testing by David Allsopp and
+ Olivier Andrieu)
+
+- PR#6903: Unix.execvpe doesn't change environment on Cygwin
+ (Xavier Leroy)
+
+- PR#6987: Strange error message probably caused by universal variable escape
+ (with polymorphic variants)
+ (report by Leo White)
+
+- PR#7216, GPR#949: don't require double parens in Functor((val x))
+ (Jacques Garrigue, review by Valentin Gatien-Baron)
+
+- PR#7331: ocamldoc, avoid infinite loop in presence of self alias,
+ i.e. module rec M:sig end = M
+ (Florian Angeletti, review Gabriel Scherer)
+
+- PR#7346, GPR#966: Fix evaluation order problem whereby expressions could
+ be incorrectly re-ordered when compiling with Flambda. This also fixes one
+ example of evaluation order in the native code compiler not matching the
+ bytecode compiler (even when not using Flambda)
+ (Mark Shinwell, Leo White, code review by Pierre Chambart)
+
+- PR#7348: Private row variables can escape their scope
+ (Jacques Garrigue, report by Leo White)
+
+- PR#7407: Two not-quite-standard C idioms rejected by SUNWSPro compilers
+ (Xavier Leroy)
+
+- PR#7421: Soundness bug with GADTs and lazy
+ (Jacques Garrigue, report by Leo White)
+
+- PR#7424: Typechecker diverges on unboxed type declaration
+ (Jacques Garrigue, report by Stephen Dolan)
+
+- PR#7426, GPR#965: Fix fatal error during object compilation (also
+ introduces new [Pfield_computed] and [Psetfield_computed] primitives)
+ (Mark Shinwell)
+
+- PR#7427, GPR#959: Don't delete let bodies in Cmmgen
+ (Mark Shinwell)
+
+- PR#7432: Linking modules compiled with -labels and -nolabels is not safe
+ (Jacques Garrigue, report by Jeremy Yallop)
+
+- PR#7437: typing assert failure with nonrec priv
+ (Jacques Garrigue, report by Anil Madhavapeddy)
+
+- PR#7438: warning +34 exposes #row with private types
+ (Alain Frisch, report by Anil Madhavapeddy)
+
+- PR#7443, GPR#990: spurious unused open warning with local open in patterns
+ (Florian Angeletti, report by Gabriel Scherer)
+
+- PR#7504: fix warning 8 with unconstrained records
+ (Florian Angeletti, report by John Whitington)
+
+- PR#7456, GPR#1092: fix slow compilation on source files containing a lot
+ of similar debugging information location entries
+ (Mark Shinwell)
+
+- GPR#805, GPR#815, GPR#833: check for integer overflow in String.concat
+ (Jeremy Yallop,
+ review by Damien Doligez, Alain Frisch, Daniel Bünzli, Fabrice Le Fessant)
+
+- GPR#810: check for integer overflow in Array.concat
+ (Jeremy Yallop)
+
+- GPR#814: fix the Buffer.add_substring bounds check to handle overflow
+ (Jeremy Yallop)
+
+- GPR#881: short-paths did not apply to some polymorphic variants
+ (Valentin Gatien-Baron, review by Leo White)
+
+- GPR#886: Fix Ctype.moregeneral's handling of row_name
+ (Leo White)
+
+- GPR#934: check for integer overflow in Bytes.extend
+ (Jeremy Yallop, review by Gabriel Scherer)
+
+- GPR#956: Keep possibly-effectful expressions when optimizing multiplication
+ by zero.
+ (Jeremy Yallop)
+
+- GPR#977: Catch Out_of_range in ocamldebug's "list" command
+ (Yunxing Dai)
+
+- GPR#983: Avoid removing effectful expressions in Closure, and
+ eliminate more non-effectful ones
+ (Alain Frisch, review by Mark Shinwell and Gabriel Scherer)
+
+- GPR#987: alloc_sockaddr: don't assume a null terminator. It is not inserted
+ on macOS by system calls that fill in a struct sockaddr (e.g. getsockname).
+ (Anton Bachin)
+
+- GPR#998: Do not delete unused closures in un_anf.ml.
+ (Leo White)
+
+- GPR#1019: Fix fatal error in Flambda mode "[functions] does not map set of
+ closures ID"
+ (Pierre Chambart, code review by Mark Shinwell and Leo White)
+
+- GPR#1075: Ensure that zero-sized float arrays have zero tags.
+ (Mark Shinwell, Leo White)
+
+* GPR#1088: Gc.minor_words now returns accurate numbers.
+ (Stephen Dolan)
+
+OCaml 4.04.2 (23 Jun 2017):
+---------------------------
+
+### Security fix:
+
+- PR#7557: Local privilege escalation issue with ocaml binaries.
+ (Damien Doligez, report by Eric Milliken, review by Xavier Leroy)
+
+OCaml 4.04.1 (14 Apr 2017):
+---------------------------
+
+- PR#7501, GPR#1089: Consider arrays of length zero as constants
+ when using Flambda.
+ (Pierre Chambart, review by Mark Shinwell and Leo White)
+
+### Standard library:
+
+- PR#7403, GPR#894: fix a bug in Set.map as introduced in 4.04.0
+ (Gabriel Scherer, report by Thomas Leonard)
+
+### Tools:
+
+- PR#7411: ocamldoc, avoid nested <pre> tags in module description.
+ (Florian Angeletti, report by user 'kosik')
+
+- PR#7488: ocamldoc, wrong Latex output for variant types
+ with constructors without arguments.
+ (Florian Angeletti, report by Xavier Leroy)
+
+### Build system:
+
+- PR#7373, GPR#1023: New flexlink target in Makefile.nt to bootstrap the
+ flexlink binary only, rather than the flexlink binary and the FlexDLL C
+ objects.
+ (David Allsopp)
+
+### Bug fixes
+
+- PR#7369: Str.regexp raises "Invalid_argument: index out of bounds"
+ (Damien Doligez, report by John Whitington)
+
+- PR#7373, GPR#1023: Fix ocamlmklib with bootstrapped FlexDLL. Bootstrapped
+ FlexDLL objects are now installed to a subdirectory flexdll of the Standard
+ Library which allows the compilers to pick them up explicitly and also
+ ocamlmklib to include them without unnecessarily adding the entire Standard
+ Library.
+ (David Allsopp)
+
+- PR#7385, GPR#1057: fix incorrect timestamps returned by Unix.stat on Windows
+ when either TZ is set or system date is in DST.
+ (David Allsopp, report and initial fix by Nicolás Ojeda Bär, review and
+ superior implementation suggestion by Xavier Leroy)
+
+- PR#7405, GPR#903: s390x: Fix address of caml_raise_exn in native dynlink modules
+ (Richard Jones, review by Xavier Leroy)
+
+- PR#7417, GPR#930: ensure 16 byte stack alignment inside caml_allocN on x86-64
+ for ocaml build with WITH_FRAME_POINTERS defined
+ (Christoph Cullmann)
+
+- PR#7456, GPR#1092: fix slow compilation on source files containing a lot
+ of similar debugging information location entries
+ (Mark Shinwell)
+
+- PR#7457: a case of double free in the systhreads library (POSIX implementation)
+ (Xavier Leroy, report by Chet Murthy)
+
+- PR#7460, GPR#1011: catch uncaught exception when unknown files are passed
+ as argument (regression in 4.04.0)
+ (Bernhard Schommer, review by Florian Angeletti and Gabriel Scherer,
+ report by Stephen Dolan)
+
+- PR#7505: Memory cannot be released after calling
+ Bigarray.Genarray.change_layout.
+ (Damien Doligez and Xavier Leroy, report by Liang Wang)
+
+- PR#7511, GPR#1133: Unboxed type with unboxed argument should not be accepted
+ (Damien Doligez, review by Jeremy Yallop and Leo White)
+
+- GPR#912: Fix segfault in Unix.create_process on Windows caused by wrong header
+ configuration.
+ (David Allsopp)
+
+- GPR#980: add dynlink options to ocamlbytecomp.cmxa to allow ocamlopt.opt
+ to load plugins. See http://github.com/OCamlPro/ocamlc-plugins for examples.
+ (Fabrice Le Fessant, review by David Allsopp)
+
+- GPR#992: caml-types.el: Fix missing format argument, so that it can show kind
+ of call at point correctly.
+ (Chunhui He)
+
+- GPR#1043: Allow Windows CRLF line-endings in ocamlyacc on Unix and Cygwin.
+ (David Allsopp, review by Damien Doligez and Xavier Leroy)
+
+- GPR#1072: Fix segfault in Sys.runtime_parameters when exception backtraces
+ are enabled.
+ (Olivier Andrieu)
+
+OCaml 4.04.0 (4 Nov 2016):
+--------------------------
(Changes that can break existing programs are marked with a "*")
(Alain Frisch)
- GPR#508: Allow shortcut for extension on semicolons: ;%foo
- (Jeremie Dimino)
+ (Jérémie Dimino)
- GPR#606: optimized representation for immutable records with a single
field, and concrete types with a single constructor with a single argument.
### Standard library:
-- GPR#473: Provide `Sys.backend_type` so that user can write backend-specific
- code in some cases (for example, code generator).
- (Hongbo Zhang)
-
- PR#6279, GPR#553: implement Set.map
(Gabriel Scherer)
"transitive" heap size of a value
(Alain Frisch, review by Mark Shinwell and Damien Doligez)
+- GPR#473: Provide `Sys.backend_type` so that user can write backend-specific
+ code in some cases (for example, code generator).
+ (Hongbo Zhang)
+
- GPR#589: Add a non-allocating function to recover the number of
allocated minor words.
(Pierre Chambart, review by Damien Doligez and Gabriel Scherer)
(Alain Frisch)
- GPR#669: Filename.extension and Filename.remove_extension
- (Alain Frisch, request by Edgar Aroutiounian, review by Daniel Bunzli
+ (Alain Frisch, request by Edgar Aroutiounian, review by Daniel Bünzli
and Damien Doligez)
+- GPR#674: support unknown Sys.os_type in Filename, defaulting to Unix
+ (Filename would previously fail at initialization time for
+ Sys.os_type values other than "Unix", "Win32" and "Cygwin";
+ mirage-os uses "xen")
+ (Anil Madhavapeddy)
+
+- 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)
+
+### Other libraries
+
+- MPR#4834, GPR#592: Add a Biggarray.Genarray.change_layout function
+ to switch bigarrays between C and fortran layouts.
+ (Guillaume Hennequin, review by Florian Angeletti)
+
### Code generation and optimizations:
- PR#4747, GPR#328: Optimize Hashtbl by using in-place updates of its
slower
(Alain Frisch)
-* PR#6217, GPR#538: Optimize performance of record update:
+- PR#6217, GPR#538: Optimize performance of record update:
no more performance cliff when { foo with t1 = ..; t2 = ...; ... }
hits 6 updated fields
(Olivier Nicole, review by Thomas Braibant and Pierre Chambart)
not always preserve the arguments
(Pierre Chambart, Mark Shinwell, report by Simon Cruanes)
+- PR#7328, GPR#702: Do not eliminate boxed int divisions by zero and
+ avoid checking twice if divisor is zero with flambda.
+ (Pierre Chambart, report by Jeremy Yallop)
+
- GPR#427: Obj.is_block is now an inlined OCaml function instead of a
C external. This should be faster.
(Demi Obenour)
- GPR#602: Do not generate dummy code to force module linking
(Pierre Chambart, reviewed by Jacques Garrigue)
-- PR#7328, GPR#702: Do not eliminate boxed int divisions by zero and
- avoid checking twice if divisor is zero with flambda.
- (Pierre Chambart, report by Jeremy Yallop)
-
- GPR#703: Optimize some constant string operations when the "-safe-string"
configure time option is enabled.
(Pierre Chambart)
### Runtime system:
+- PR#7203, GPR#534: Add a new primitive caml_alloc_float_array to allocate an
+ array of floats
+ (Thomas Braibant)
+
- PR#7210, GPR#562: Allows to register finalisation function that are
called only when a value will never be reachable anymore. The
drawbacks compared to the existing one is that the finalisation
are registered with `GC.finalise_last`
(François Bobot reviewed by Damien Doligez and Leo White)
+- GPR#247: In previous OCaml versions, inlining caused stack frames to
+ disappear from stacktraces. This made debugging harder in presence of
+ optimizations, and flambda was going to make this worse. The debugging
+ information produced by the compiler now enables the reconstruction of the
+ original backtrace. Use `Printexc.get_raw_backtrace_next_slot` to traverse
+ the list of inlined stack frames.
+ (Frédéric Bour, review by Mark Shinwell and Xavier Leroy)
+
- GPR#590: Do not perform compaction if the real overhead is less than expected
(Thomas Braibant)
- GPR#585: Spacetime, a new memory profiler (Mark Shinwell, Leo White)
-### Runtime system:
-
-- PR#7203, GPR#534: Add a new primitive caml_alloc_float_array to allocate an
- array of floats
- (Thomas Braibant)
-
### Manual and documentation:
- PR#7007, PR#7311: document the existence of OCAMLPARAM and
- PR#7355: Gc.finalise and lazy values
(Jeremy Yallop)
-- GPR#841: Document that [Store_field] must not be used to populate
+- GPR#842: Document that [Store_field] must not be used to populate
arrays of values declared using [CAMLlocalN] (Mark Shinwell)
-### Build system:
+### Compiler distribution build system:
- GPR#324: Compiler developers: Adding new primitives to the
standard runtime doesn't require anymore to run `make bootstrap`
built.
(Demi Obenour)
+- GPR#525: fix build on OpenIndiana
+ (Sergey Avseyev, review by Damien Doligez)
+
- GPR#687: "./configure -safe-string" to get a system where
"-unsafe-string" is not allowed, thus giving stronger non-local
guarantees about immutability of strings
- GPR#880: Fix [@@inline] with default parameters in flambda (Leo White)
-- GPR#525: fix build on OpenIndiana
- (Sergey Avseyev, review by Damien Doligez)
-
### Internal/compiler-libs changes:
- PR#7200, GPR#539: Improve, fix, and add test for parsing/pprintast.ml
- GPR#112: octal escape sequences for char and string literals
"Make it \o033[1mBOLD\o033[0m"
- (Rafaël Bocquet, request by John Whitingthon)
+ (Rafaël Bocquet, request by John Whitington)
- GPR#167: allow to annotate externals' arguments and result types so
they can be unboxed or untagged: [@unboxed], [@untagged]. Supports
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.
(Pierre Chambart)
* GPR#297: Several changes to improve the worst-case GC pause time.
Changes Gc.control and Gc.major_slice and adds functions to the Gc module.
- (Damien Doligez, with help from Francois Bobot, Thomas Braibant, Leo White)
+ (Damien Doligez, with help from François Bobot, Thomas Braibant, Leo White)
- GPR#325: Add v=0x400 flag to OCAMLRUNPARAM to display GC stats on exit
(Louis Gesbert, review by Alain Frisch)
(Jacques Garrigue, report by Leo White)
- PR#6954: Infinite loop in type checker with module aliases
- (Jacques Garrigue, report by Mark Mottl)
+ (Jacques Garrigue, report by Markus Mottl)
- PR#6972, GPR#276: 4.02.3 regression on documentation comments in .cmt files
(Leo White, report by Olivier Andrieu)
(Krzysztof Pszeniczny)
- GPR#205: Clear caml_backtrace_last_exn before registering as root
- (report and fix by Frederic Bour)
+ (report and fix by Frédéric Bour)
- GPR#220: minor -dsource error on recursive modules
(Hongbo Zhang)
- PR#6669: fix 4.02 regression in toplevel printing of lazy values
(Leo White, review by Gabriel Scherer)
- PR#6671: Windows: environment variable 'TZ' affects Unix.gettimeofday
- (Mickael Delahaye and Damien Doligez)
+ (Mickaël Delahaye and Damien Doligez)
- PR#6680: Missing parentheses in warning about polymorphic variant value
(Jacques Garrigue and Gabriel Scherer, report by Philippe Veber)
- PR#6686: Bug in [subst_boxed_number]
- Module Printf:
added %S and %C formats (quoted, escaped strings and characters);
added kprintf (calls user-specified continuation on formatted string).
-- Module Queue: faster implementation (courtesy of Francois Pottier).
+- Module Queue: faster implementation (courtesy of François Pottier).
- Module Random: added Random.bool.
- Module Stack: added Stack.is_empty.
- Module Pervasives:
Objective Caml 1.00 (9 May 1996):
---------------------------------
-* Merge of Jerome Vouillon and Didier Remy's object-oriented
+* Merge of Jérôme Vouillon and Didier Rémy's object-oriented
extensions.
* All libraries: all "new" functions renamed to "create" because "new"
--- /dev/null
+= Hacking the compiler 🐫
+
+This document is a work-in-progress attempt to provide useful
+information for people willing to inspect or modify the compiler
+distribution's codebase. Feel free to improve it by sending change
+proposals for it.
+
+If you already have a patch that you would like to contribute to the
+official distribution, please see link:CONTRIBUTING.md[].
+
+=== Your first compiler modification
+
+1. Create a new git branch to store your changes.
++
+----
+git checkout -b my-modification
+----
+
+2. Consult link:INSTALL.adoc[] for build instructions. Here is the gist of it:
++
+----
+./configure
+make world.opt
+----
+
+3. Try the newly built compiler binaries `ocamlc`, `ocamlopt` or their
+`.opt` version. To try the toplevel, use:
++
+----
+make runtop
+----
+
+4. Hack frenetically and keep rebuilding.
+
+5. Run the testsuite from time to time.
++
+----
+make tests
+----
+
+5. Install in a new opam switch to try things out:
++
+----
+opam compiler-conf install
+----
+
+6. You did it, Well done! Consult link:CONTRIBUTING.md[] to send your contribution upstream.
+
+See our <<Development tips and tricks>> for various helpful details,
+for example on how to automatically <<opam compiler script,create an
+opam switch>> from a compiler branch.
+
+=== What to do
+
+There is always a lot of potential tasks, both for old and
+newcomers. Here are various potential projects:
+
+* http://caml.inria.fr/mantis/view_all_bug_page.php[The OCaml
+ bugtracker] contains reported bugs and feature requests. Some
+ changes that should be accessible to newcomers are marked with the
+ tag
+ http://caml.inria.fr/mantis/search.php?project_id=1&sticky_issues=1&sortby=last_updated&dir=DESC&highlight_changed=24&hide_status_id=90&tag_string=junior_job[junior_job].
+
+* The
+ https://github.com/ocamllabs/compiler-hacking/wiki/Things-to-work-on[OCaml
+ Labs compiler-hacking wiki] contains various ideas of changes to
+ propose, some easy, some requiring a fair amount of work.
+
+* Documentation improvements are always much appreciated, either in
+ the various `.mli` files or in the official manual
+ (See link:manual/README.md[]). If you invest effort in understanding
+ a part of the codebase, submitting a pull request that adds
+ clarifying comments can be an excellent contribution to help you,
+ next time, and other code readers.
+
+* The https://github.com/ocaml/ocaml[github project] contains a lot of
+ pull requests, many of them being in dire need of a review -- we
+ have more people willing to contribute changes than to review
+ someone else's change. Picking one of them, trying to understand the
+ code (looking at the code around it) and asking questions about what
+ you don't understand or what feels odd is super-useful. It helps the
+ contribution process, and it is also an excellent way to get to know
+ various parts of the compiler from the angle of a specific aspect or
+ feature.
++
+Again, reviewing small or medium-sized pull requests is accessible to
+anyone with OCaml programming experience, and helps maintainers and
+other contributors. If you also submit pull requests yourself, a good
+discipline is to review at least as many pull requests as you submit.
+
+== Structure of the compiler
+
+The compiler codebase can be intimidating at first sight. Here are
+a few pointers to get started.
+
+=== Compilation pipeline
+
+==== The driver -- link:driver/[]
+
+The driver contains the "main" function of the compilers that drive
+compilation. It parses the command-line arguments and composes the
+required compiler passes by calling functions from the various parts
+of the compiler described below.
+
+==== Parsing -- link:parsing/[]
+
+Parses source files and produces an Abstract Syntax Tree (AST)
+(link:parsing/parsetree.mli[] has lot of helpful comments). See
+link:parsing/HACKING.adoc[].
+
+The logic for Camlp4 and Ppx preprocessing is not in link:parsing/[],
+but in link:driver/[], see link:driver/pparse.mli[],
+link:driver/pparse.mli[].
+
+==== Typing -- link:typing/[]
+
+Type-checks the AST and produces a typed representation of the program
+(link:parsing/typedtree.mli[] has some helpful comments). See
+link:typing/HACKING.adoc[].
+
+==== The bytecode compiler -- link:bytecomp/[]
+
+==== The native compiler -- link:middle_end/[] and link:asmcomp/[]
+
+=== Runtime system
+
+=== Libraries
+
+link:stdlib/[]:: The standard library. Each file is largely
+independent and should not need further knowledge.
+
+link:otherlibs/[]:: External libraries such as `unix`, `threads`,
+`dynlink`, `str` and `bigarray`.
+
+=== Tools
+
+link:lex/[]:: The `ocamllex` lexer generator.
+
+link:yacc/[]:: The `ocamlyacc` parser generator. We do not recommend
+using it for user projects in need of a parser generator. Please
+consider using and contributing to
+link:http://gallium.inria.fr/~fpottier/menhir/[menhir] instead, which
+has tons of extra features, lets you write more readable grammars, and
+has excellent documentation.
+
+=== Complete file listing
+
+ Changes:: what's new with each release
+ configure:: configure script
+ CONTRIBUTING.md:: how to contribute to OCaml
+ HACKING.adoc:: this file
+ INSTALL.adoc:: instructions for installation
+ LICENSE:: license and copyright notice
+ Makefile:: main Makefile
+ Makefile.nt:: Windows Makefile (deprecated)
+ Makefile.shared:: common Makefile
+ Makefile.tools:: used by manual/ and testsuite/ Makefiles
+ README.adoc:: general information on the compiler distribution
+ README.win32.adoc:: general information on the 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/:: configuration files
+ 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/:: git submodule -- see link: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 additional libraries
+ parsing/:: syntax analysis -- see link:parsing/HACKING.adoc[]
+ stdlib/:: standard library
+ testsuite/:: tests -- see link:testsuite/HACKING.adoc[]
+ tools/:: various utilities
+ toplevel/:: interactive system
+ typing/:: typechecking -- see link:typing/HACKING.adoc[]
+ utils/:: utility libraries
+ yacc/:: parser generator
+
+== Development tips and tricks
+
+=== opam compiler script
+
+The separately-distributed script
+https://github.com/gasche/opam-compiler-conf[`opam-compiler-conf`] can
+be used to easily build opam switches out of a git branch of the
+compiler distribution. This lets you easily install and test opam
+packages from an under-modification compiler version.
+
+=== Useful Makefile targets
+
+Besides the targets listed in link:INSTALL.adoc[] for build and
+installation, the following targets may be of use:
+
+`make runtop` :: builds and runs the ocaml toplevel of the distribution
+ (optionally uses `rlwrap` for readline+history support)
+`make natruntop`:: builds and runs the native ocaml toplevel (experimental)
+
+`make partialclean`:: Clean the OCaml files but keep the compiled C files.
+
+`make depend`:: Regenerate the `.depend` file. Should be used each time new dependencies are added between files.
+
+`make -C testsuite parallel`:: see link:testsuite/HACKING.adoc[]
+
+=== Bootstrapping
+
+The OCaml compiler is bootstrapped. This means that
+previously-compiled bytecode versions of the compiler, dependency
+generator and lexer are included in the repository under the
+link:boot/[] directory. These bytecode images are used once the
+bytecode runtime (which is written in C) has been built to compile the
+standard library and then to build a fresh compiler. Details can be
+found in link:INSTALL.adoc#bootstrap[INSTALL.adoc].
+
+=== Continuous integration
+
+==== Github's CI: Travis and AppVeyor
+
+==== INRIA's Continuous Integration (CI)
+
+INRIA provides a Jenkins continuous integration service that OCaml
+uses, see link:https://ci.inria.fr/ocaml/[]. It provides a wider
+architecture support (MSVC and MinGW, a zsystems s390x machine, and
+various MacOS versions) than the Travis/AppVeyor testing on github,
+but only runs on commits to the trunk or release branches, not on every
+PR.
+
+You do not need to be an INRIA employee to open an account on this
+jenkins service; anyone can create an account there to access build
+logs, enable email notifications, and manually restart builds. If you
+would like to do this but have trouble doing it, please contact Damien
+Doligez or Gabriel Scherer.
+
+==== Running INRIA's CI on a github Pull Request (PR)
+
+If you have suspicions that a PR may fail on exotic architectures
+(it touches the build system or the backend code generator,
+for example) and would like to get wider testing than github's CI
+provides, it is possible to manually start INRIA's CI on arbitrary git
+branches by pushing to a `precheck` branch of the main repository.
+
+This is done by pushing to a specific github repository that the CI
+watches, namely
+link:https://github.com/ocaml/precheck[ocaml/precheck]. You thus need
+to have write/push/commit access to this repository to perform this operation.
+
+Just checkout the commit/branch you want to test, then run
+
+ git push --force git@github.com:ocaml/precheck.git HEAD:trunk
+
+(This is the syntax to push the current `HEAD` state into the `trunk`
+reference on the specified remote.)
\ No newline at end of file
-= Installing OCaml on a Unix(-like) machine =
+= Installing OCaml from sources on a Unix(-like) machine =
== PREREQUISITES
`-no-curses`::
Do not use the curses library.
+ The only use for this is to highlight errors in the toplevel using
+ 'standout' mode, e.g. underline, rather than with '^' on a newline.
`-host <hosttype>`:: (default: determined automatically)
The type of the host machine, in GNU's "configuration name" format
make world > log.world 2>&1 # in sh
make world >& log.world # in csh
+[[bootstrap]]
3. (Optional) To be sure everything works well, you can try to bootstrap the
system -- that is, to recompile all OCaml sources with the newly created
compiler. From the top directory, do:
# The main Makefile
-MAKEREC=$(MAKE)
-include Makefile.shared
+# Hard bootstrap how-to:
+# (only necessary in some cases, for example if you remove some primitive)
+#
+# make coreboot [old system -- you were in a stable state]
+# <change the source>
+# make clean runtime coreall
+# <debug your changes>
+# make clean runtime coreall
+# make coreboot [new system -- now in a stable state]
-SHELL=/bin/sh
-MKDIR=mkdir -p
+include config/Makefile
# For users who don't read the INSTALL file
+.PHONY: defaultentry
defaultentry:
+ifeq "$(UNIX_OR_WIN32)" "unix"
@echo "Please refer to the installation instructions in file INSTALL."
@echo "If you've just unpacked the distribution, something like"
@echo " ./configure"
@echo " make world.opt"
@echo " make install"
@echo "should work. But see the file INSTALL for more details."
+else
+ @echo "Please refer to the instructions in file README.win32.adoc."
+endif
-# Recompile the system using the bootstrap compiler
-all:
- $(MAKE) runtime
- $(MAKE) coreall
- $(MAKE) ocaml
- $(MAKE) otherlibraries $(WITH_DEBUGGER) \
- $(WITH_OCAMLDOC)
+MKDIR=mkdir -p
+ifeq "$(UNIX_OR_WIN32)" "win32"
+LN = cp
+else
+LN = ln -sf
+endif
+
+CAMLRUN ?= boot/ocamlrun
+CAMLYACC ?= boot/ocamlyacc
+include stdlib/StdlibModules
+
+CAMLC=$(CAMLRUN) boot/ocamlc -g -nostdlib -I boot -use-prims byterun/primitives
+CAMLOPT=$(CAMLRUN) ./ocamlopt -g -nostdlib -I stdlib -I otherlibs/dynlink
+ARCHES=amd64 i386 arm arm64 power sparc s390x
+INCLUDES=-I utils -I parsing -I typing -I bytecomp -I middle_end \
+ -I middle_end/base_types -I asmcomp -I driver -I toplevel
+
+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=
+
+ifeq "$(strip $(NATDYNLINKOPTS))" ""
+OCAML_NATDYNLINKOPTS=
+else
+OCAML_NATDYNLINKOPTS = -ccopt "$(NATDYNLINKOPTS)"
+endif
+
+ifeq "$(strip $(BYTECCLINKOPTS))" ""
+OCAML_BYTECCLINKOPTS=
+else
+OCAML_BYTECCLINKOPTS = -ccopt "$(BYTECCLINKOPTS)"
+endif
+
+YACCFLAGS=-v --strict
+CAMLLEX=$(CAMLRUN) boot/ocamllex
+CAMLDEP=$(CAMLRUN) tools/ocamldep
+DEPFLAGS=$(INCLUDES)
+
+OCAMLDOC_OPT=$(WITH_OCAMLDOC:=.opt)
+
+UTILS=utils/config.cmo utils/misc.cmo \
+ utils/identifiable.cmo utils/numbers.cmo utils/arg_helper.cmo \
+ utils/clflags.cmo utils/tbl.cmo utils/timings.cmo \
+ utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \
+ utils/consistbl.cmo \
+ utils/strongly_connected_components.cmo \
+ utils/targetint.cmo
+
+PARSING=parsing/location.cmo parsing/longident.cmo \
+ parsing/docstrings.cmo parsing/syntaxerr.cmo \
+ parsing/ast_helper.cmo parsing/parser.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/depend.cmo
+
+TYPING=typing/ident.cmo typing/path.cmo \
+ typing/primitive.cmo typing/types.cmo \
+ typing/btype.cmo typing/oprint.cmo \
+ typing/subst.cmo typing/predef.cmo \
+ typing/datarepr.cmo typing/cmi_format.cmo typing/env.cmo \
+ typing/typedtree.cmo typing/printtyped.cmo typing/ctype.cmo \
+ typing/printtyp.cmo typing/includeclass.cmo \
+ typing/mtype.cmo typing/envaux.cmo typing/includecore.cmo \
+ typing/typedtreeIter.cmo typing/typedtreeMap.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/typedecl.cmo typing/typecore.cmo \
+ typing/typeclass.cmo \
+ typing/typemod.cmo
+
+COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \
+ bytecomp/semantics_of_primitives.cmo \
+ bytecomp/typeopt.cmo bytecomp/switch.cmo bytecomp/matching.cmo \
+ bytecomp/translobj.cmo bytecomp/translattribute.cmo \
+ bytecomp/translcore.cmo \
+ bytecomp/translclass.cmo bytecomp/translmod.cmo \
+ bytecomp/simplif.cmo bytecomp/runtimedef.cmo \
+ driver/pparse.cmo driver/main_args.cmo \
+ driver/compenv.cmo driver/compmisc.cmo
+
+COMMON=$(UTILS) $(PARSING) $(TYPING) $(COMP)
+
+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
+
+ARCH_SPECIFIC =\
+ asmcomp/arch.ml asmcomp/proc.ml asmcomp/CSE.ml asmcomp/selection.ml \
+ asmcomp/scheduling.ml asmcomp/reload.ml
+
+INTEL_ASM=\
+ asmcomp/x86_proc.cmo \
+ asmcomp/x86_dsl.cmo \
+ asmcomp/x86_gas.cmo \
+ asmcomp/x86_masm.cmo
+
+ARCH_SPECIFIC_ASMCOMP=
+ifeq ($(ARCH),i386)
+ARCH_SPECIFIC_ASMCOMP=$(INTEL_ASM)
+endif
+ifeq ($(ARCH),amd64)
+ARCH_SPECIFIC_ASMCOMP=$(INTEL_ASM)
+endif
+
+ASMCOMP=\
+ $(ARCH_SPECIFIC_ASMCOMP) \
+ asmcomp/arch.cmo \
+ asmcomp/cmm.cmo asmcomp/printcmm.cmo \
+ asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \
+ asmcomp/clambda.cmo asmcomp/printclambda.cmo \
+ asmcomp/export_info.cmo \
+ asmcomp/export_info_for_pack.cmo \
+ asmcomp/compilenv.cmo \
+ asmcomp/closure.cmo \
+ asmcomp/build_export_info.cmo \
+ asmcomp/closure_offsets.cmo \
+ asmcomp/flambda_to_clambda.cmo \
+ asmcomp/import_approx.cmo \
+ asmcomp/un_anf.cmo \
+ asmcomp/afl_instrument.cmo \
+ asmcomp/strmatch.cmo asmcomp/cmmgen.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 \
+ asmcomp/spill.cmo asmcomp/split.cmo \
+ asmcomp/interf.cmo asmcomp/coloring.cmo \
+ asmcomp/reloadgen.cmo asmcomp/reload.cmo \
+ asmcomp/deadcode.cmo \
+ asmcomp/printlinear.cmo asmcomp/linearize.cmo \
+ asmcomp/schedgen.cmo asmcomp/scheduling.cmo \
+ asmcomp/branch_relaxation_intf.cmo \
+ asmcomp/branch_relaxation.cmo \
+ asmcomp/emitaux.cmo asmcomp/emit.cmo asmcomp/asmgen.cmo \
+ asmcomp/asmlink.cmo asmcomp/asmlibrarian.cmo asmcomp/asmpackager.cmo \
+ 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 \
+ middle_end/base_types/variable.cmo \
+ middle_end/base_types/mutable_variable.cmo \
+ middle_end/base_types/id_types.cmo \
+ middle_end/base_types/set_of_closures_id.cmo \
+ middle_end/base_types/set_of_closures_origin.cmo \
+ middle_end/base_types/closure_element.cmo \
+ middle_end/base_types/closure_id.cmo \
+ middle_end/base_types/var_within_closure.cmo \
+ middle_end/base_types/static_exception.cmo \
+ middle_end/base_types/export_id.cmo \
+ middle_end/base_types/symbol.cmo \
+ middle_end/pass_wrapper.cmo \
+ middle_end/allocated_const.cmo \
+ middle_end/projection.cmo \
+ middle_end/flambda.cmo \
+ middle_end/flambda_iterators.cmo \
+ middle_end/flambda_utils.cmo \
+ middle_end/inlining_cost.cmo \
+ middle_end/effect_analysis.cmo \
+ middle_end/freshening.cmo \
+ middle_end/simple_value_approx.cmo \
+ middle_end/lift_code.cmo \
+ middle_end/closure_conversion_aux.cmo \
+ middle_end/closure_conversion.cmo \
+ middle_end/initialize_symbol_to_let_symbol.cmo \
+ middle_end/lift_let_to_initialize_symbol.cmo \
+ middle_end/find_recursive_functions.cmo \
+ middle_end/invariant_params.cmo \
+ middle_end/inconstant_idents.cmo \
+ middle_end/alias_analysis.cmo \
+ middle_end/lift_constants.cmo \
+ middle_end/share_constants.cmo \
+ middle_end/simplify_common.cmo \
+ middle_end/remove_unused_arguments.cmo \
+ middle_end/remove_unused_closure_vars.cmo \
+ middle_end/remove_unused_program_constructs.cmo \
+ middle_end/simplify_boxed_integer_ops.cmo \
+ middle_end/simplify_primitives.cmo \
+ middle_end/inlining_stats_types.cmo \
+ middle_end/inlining_stats.cmo \
+ middle_end/inline_and_simplify_aux.cmo \
+ middle_end/remove_free_vars_equal_to_args.cmo \
+ middle_end/extract_projections.cmo \
+ middle_end/augment_specialised_args.cmo \
+ middle_end/unbox_free_vars_of_closures.cmo \
+ middle_end/unbox_specialised_args.cmo \
+ middle_end/unbox_closures.cmo \
+ middle_end/inlining_transforms.cmo \
+ middle_end/inlining_decision.cmo \
+ middle_end/inline_and_simplify.cmo \
+ middle_end/ref_to_variables.cmo \
+ middle_end/flambda_invariants.cmo \
+ middle_end/middle_end.cmo
+
+TOPLEVEL=toplevel/genprintval.cmo toplevel/toploop.cmo \
+ toplevel/trace.cmo toplevel/topdirs.cmo toplevel/topmain.cmo
+
+OPTTOPLEVEL=toplevel/genprintval.cmo toplevel/opttoploop.cmo \
+ toplevel/opttopdirs.cmo toplevel/opttopmain.cmo
+BYTESTART=driver/main.cmo
+
+OPTSTART=driver/optmain.cmo
+
+TOPLEVELSTART=toplevel/topstart.cmo
+
+OPTTOPLEVELSTART=toplevel/opttopstart.cmo
+
+PERVASIVES=$(STDLIB_MODULES) outcometree topdirs toploop
-# Compile everything the first time
-world:
- $(MAKE) coldstart
- $(MAKE) all
+LIBFILES=stdlib.cma std_exit.cmo *.cmi camlheader
-# Compile also native code compiler and libraries, fast
-world.opt:
- $(MAKE) coldstart
- $(MAKE) opt.opt
+MAXSAVED=boot/Saved/Saved.prev/Saved.prev/Saved.prev/Saved.prev/Saved.prev
-reconfigure:
- ./configure $(CONFIGURE_ARGS)
+COMPLIBDIR=$(LIBDIR)/compiler-libs
-# Hard bootstrap how-to:
-# (only necessary in some cases, for example if you remove some primitive)
-#
-# make coreboot [old system -- you were in a stable state]
-# <change the source>
-# make clean runtime coreall
-# <debug your changes>
-# make clean runtime coreall
-# make coreboot [new system -- now in a stable state]
+INSTALL_BINDIR=$(DESTDIR)$(BINDIR)
+INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
+INSTALL_COMPLIBDIR=$(DESTDIR)$(COMPLIBDIR)
+INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR)
+INSTALL_MANDIR=$(DESTDIR)$(MANDIR)
+INSTALL_FLEXDLL=$(INSTALL_LIBDIR)/flexdll
+
+RUNTOP=./byterun/ocamlrun ./ocaml \
+ -nostdlib -I stdlib \
+ -noinit $(TOPFLAGS) \
+ -I otherlibs/$(UNIXLIB)
+NATRUNTOP=./ocamlnat$(EXE) -nostdlib -I stdlib -noinit $(TOPFLAGS)
+ifeq "UNIX_OR_WIN32" "unix"
+EXTRAPATH=
+else
+EXTRAPATH = PATH="otherlibs/win32unix:$(PATH)"
+endif
+
+BOOT_FLEXLINK_CMD=
+
+ifeq "$(UNIX_OR_WIN32)" "win32"
+FLEXDLL_SUBMODULE_PRESENT := $(wildcard flexdll/Makefile)
+ifeq "$(FLEXDLL_SUBMODULE_PRESENT)" ""
+ BOOT_FLEXLINK_CMD=
+ FLEXDLL_DIR=
+else
+ BOOT_FLEXLINK_CMD = FLEXLINK_CMD="../boot/ocamlrun ../flexdll/flexlink.exe"
+ CAMLOPT := OCAML_FLEXLINK="boot/ocamlrun flexdll/flexlink.exe" $(CAMLOPT)
+ FLEXDLL_DIR=$(if $(wildcard flexdll/flexdll_*.$(O)),"+flexdll")
+endif
+else
+ FLEXDLL_DIR=
+endif
-# Core bootstrapping cycle
-coreboot:
-# Save the original bootstrap compiler
- $(MAKE) backup
-# Promote the new compiler but keep the old runtime
-# This compiler runs on boot/ocamlrun and produces bytecode for
-# byterun/ocamlrun
- $(MAKE) promote-cross
-# Rebuild ocamlc and ocamllex (run on byterun/ocamlrun)
- $(MAKE) partialclean
- $(MAKE) ocamlc ocamllex ocamltools
-# Rebuild the library (using byterun/ocamlrun ./ocamlc)
- $(MAKE) library-cross
-# Promote the new compiler and the new runtime
- $(MAKE) CAMLRUN=byterun/ocamlrun promote
-# Rebuild the core system
- $(MAKE) partialclean
- $(MAKE) core
-# Check if fixpoint reached
- $(MAKE) compare
+# The configuration file
-# Bootstrap and rebuild the whole system.
-# The compilation of ocaml will fail if the runtime has changed.
-# Never mind, just do make bootstrap to reach fixpoint again.
-bootstrap:
- $(MAKE) coreboot
- $(MAKE) all
- $(MAKE) compare
+utils/config.ml: utils/config.mlp config/Makefile
+ sed -e 's|%%AFL_INSTRUMENT%%|$(AFL_INSTRUMENT)|' \
+ -e 's|%%ARCH%%|$(ARCH)|' \
+ -e 's|%%ARCMD%%|$(ARCMD)|' \
+ -e 's|%%ASM%%|$(ASM)|' \
+ -e 's|%%ASM_CFI_SUPPORTED%%|$(ASM_CFI_SUPPORTED)|' \
+ -e 's|%%BYTECCLIBS%%|$(BYTECCLIBS)|' \
+ -e 's|%%BYTECODE_C_COMPILER%%|$(BYTECODE_C_COMPILER)|' \
+ -e 's|%%BYTERUN%%|$(BYTERUN)|' \
+ -e 's|%%CCOMPTYPE%%|$(CCOMPTYPE)|' \
+ -e 's|%%CC_PROFILE%%|$(CC_PROFILE)|' \
+ -e 's|%%EXT_ASM%%|$(EXT_ASM)|' \
+ -e 's|%%EXT_DLL%%|$(EXT_DLL)|' \
+ -e 's|%%EXT_EXE%%|$(EXE)|' \
+ -e 's|%%EXT_LIB%%|$(EXT_LIB)|' \
+ -e 's|%%EXT_OBJ%%|$(EXT_OBJ)|' \
+ -e 's|%%FLAMBDA%%|$(FLAMBDA)|' \
+ -e 's|%%FLEXLINK_FLAGS%%|$(subst \,\\,$(FLEXLINK_FLAGS))|' \
+ -e 's|%%FLEXDLL_DIR%%|$(FLEXDLL_DIR)|' \
+ -e 's|%%HOST%%|$(HOST)|' \
+ -e 's|%%LIBDIR%%|$(LIBDIR)|' \
+ -e 's|%%LIBUNWIND_AVAILABLE%%|$(LIBUNWIND_AVAILABLE)|' \
+ -e 's|%%LIBUNWIND_LINK_FLAGS%%|$(LIBUNWIND_LINK_FLAGS)|' \
+ -e 's|%%MKDLL%%|$(subst \,\\,$(MKDLL))|' \
+ -e 's|%%MKEXE%%|$(subst \,\\,$(MKEXE))|' \
+ -e 's|%%MKMAINDLL%%|$(subst \,\\,$(MKMAINDLL))|' \
+ -e 's|%%MODEL%%|$(MODEL)|' \
+ -e 's|%%NATIVECCLIBS%%|$(NATIVECCLIBS)|' \
+ -e 's|%%NATIVE_C_COMPILER%%|$(NATIVE_C_COMPILER)|' \
+ -e 's|%%PACKLD%%|$(PACKLD)|' \
+ -e 's|%%PROFILING%%|$(PROFILING)|' \
+ -e 's|%%PROFINFO_WIDTH%%|$(PROFINFO_WIDTH)|' \
+ -e 's|%%RANLIBCMD%%|$(RANLIBCMD)|' \
+ -e 's|%%SAFE_STRING%%|$(SAFE_STRING)|' \
+ -e 's|%%SYSTEM%%|$(SYSTEM)|' \
+ -e 's|%%SYSTHREAD_SUPPORT%%|$(SYSTHREAD_SUPPORT)|' \
+ -e 's|%%TARGET%%|$(TARGET)|' \
+ -e 's|%%WITH_FRAME_POINTERS%%|$(WITH_FRAME_POINTERS)|' \
+ -e 's|%%WITH_PROFINFO%%|$(WITH_PROFINFO)|' \
+ -e 's|%%WITH_SPACETIME%%|$(WITH_SPACETIME)|' \
+ $< > $@
-LIBFILES=stdlib.cma std_exit.cmo *.cmi camlheader
+ifeq "$(UNIX_OR_WIN32)" "unix"
+.PHONY: reconfigure
+reconfigure:
+ ./configure $(CONFIGURE_ARGS)
+endif
+
+.PHONY: partialclean
+partialclean::
+ rm -f utils/config.ml
+
+.PHONY: beforedepend
+beforedepend:: utils/config.ml
# Start up the system from the distribution compiler
+.PHONY: coldstart
coldstart:
- cd byterun; $(MAKE) all
+ $(MAKE) -C byterun $(BOOT_FLEXLINK_CMD) all
cp byterun/ocamlrun$(EXE) boot/ocamlrun$(EXE)
- cd yacc; $(MAKE) all
+ $(MAKE) -C yacc $(BOOT_FLEXLINK_CMD) all
cp yacc/ocamlyacc$(EXE) boot/ocamlyacc$(EXE)
- cd stdlib; \
- $(MAKE) COMPILER="../boot/ocamlc -use-prims ../byterun/primitives" all
+ $(MAKE) -C stdlib $(BOOT_FLEXLINK_CMD) \
+ 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
- if test -d stdlib/caml; then :; else \
- ln -s ../byterun/caml stdlib/caml; fi
-
-# Build the core system: the minimum needed to make depend and bootstrap
-core:
- $(MAKE) coldstart
- $(MAKE) coreall
+ cd boot; $(LN) ../byterun/libcamlrun.$(A) .
# Recompile the core system using the bootstrap compiler
+.PHONY: coreall
coreall:
$(MAKE) ocamlc
$(MAKE) ocamllex ocamlyacc ocamltools library
+# Build the core system: the minimum needed to make depend and bootstrap
+.PHONY: core
+core:
+ifeq "$(UNIX_OR_WIN32)" "unix"
+ $(MAKE) coldstart
+else # Windows, to be fixed!
+ $(MAKE) runtime
+endif
+ $(MAKE) coreall
+
# Save the current bootstrap compiler
-MAXSAVED=boot/Saved/Saved.prev/Saved.prev/Saved.prev/Saved.prev/Saved.prev
+.PHONY: backup
backup:
- if test -d boot/Saved; then : ; else mkdir boot/Saved; fi
- if test -d $(MAXSAVED); then rm -r $(MAXSAVED); else : ; fi
+ $(MKDIR) boot/Saved
+ if test -d $(MAXSAVED); then rm -r $(MAXSAVED); fi
mv boot/Saved boot/Saved.prev
mkdir boot/Saved
mv boot/Saved.prev boot/Saved/Saved.prev
cp boot/ocamlrun$(EXE) boot/Saved
- mv boot/ocamlc boot/ocamllex boot/ocamlyacc$(EXE) boot/ocamldep \
- boot/Saved
+ cd boot; mv ocamlc ocamllex ocamlyacc$(EXE) ocamldep Saved
cd boot; cp $(LIBFILES) Saved
+# Restore the saved bootstrap compiler if a problem arises
+.PHONY: restore
+restore:
+ cd boot; mv Saved/* .; rmdir Saved; mv Saved.prev Saved
+
+# Check if fixpoint reached
+.PHONY: compare
+compare:
+ @if $(CAMLRUN) tools/cmpbyt boot/ocamlc ocamlc \
+ && $(CAMLRUN) tools/cmpbyt boot/ocamllex lex/ocamllex \
+ && $(CAMLRUN) tools/cmpbyt boot/ocamldep tools/ocamldep; \
+ then echo "Fixpoint reached, bootstrap succeeded."; \
+ else echo "Fixpoint not reached, try one more bootstrapping cycle."; \
+ fi
+
# Promote the newly compiled system to the rank of cross compiler
# (Runs on the old runtime, produces code for the new runtime)
+.PHONY: promote-cross
promote-cross:
$(CAMLRUN) tools/stripdebug ocamlc boot/ocamlc
$(CAMLRUN) tools/stripdebug lex/ocamllex boot/ocamllex
# Promote the newly compiled system to the rank of bootstrap compiler
# (Runs on the new runtime, produces code for the new runtime)
+.PHONY: promote
promote: promote-cross
cp byterun/ocamlrun$(EXE) boot/ocamlrun$(EXE)
-# Restore the saved bootstrap compiler if a problem arises
-restore:
- mv boot/Saved/* boot
- rmdir boot/Saved
- mv boot/Saved.prev boot/Saved
-
-# Check if fixpoint reached
-compare:
- @if $(CAMLRUN) tools/cmpbyt boot/ocamlc ocamlc \
- && $(CAMLRUN) tools/cmpbyt boot/ocamllex lex/ocamllex \
- && $(CAMLRUN) tools/cmpbyt boot/ocamldep tools/ocamldep; \
- then echo "Fixpoint reached, bootstrap succeeded."; \
- else echo "Fixpoint not reached, try one more bootstrapping cycle."; \
- fi
-
# Remove old bootstrap compilers
+.PHONY: cleanboot
cleanboot:
rm -rf boot/Saved/Saved.prev/*
# Compile the native-code compiler
-opt-core:
- $(MAKE) runtimeopt
+.PHONY: opt-core
+opt-core: runtimeopt
$(MAKE) ocamlopt
$(MAKE) libraryopt
+.PHONY: opt
opt:
+ifeq "$(UNIX_OR_WIN32)" "unix"
$(MAKE) runtimeopt
$(MAKE) ocamlopt
$(MAKE) libraryopt
$(MAKE) otherlibrariesopt ocamltoolsopt
+else
+ $(MAKE) opt-core
+ $(MAKE) otherlibrariesopt ocamltoolsopt
+endif
# Native-code versions of the tools
+.PHONY: opt.opt
+ifeq "$(UNIX_OR_WIN32)" "unix"
opt.opt:
$(MAKE) checkstack
$(MAKE) runtime
$(MAKE) ocamlopt.opt
$(MAKE) otherlibrariesopt
$(MAKE) ocamllex.opt ocamltoolsopt ocamltoolsopt.opt $(OCAMLDOC_OPT)
+else
+opt.opt: core opt-core ocamlc.opt all ocamlopt.opt ocamllex.opt \
+ ocamltoolsopt ocamltoolsopt.opt otherlibrariesopt $(OCAMLDOC_OPT)
+endif
+.PHONY: base.opt
base.opt:
$(MAKE) checkstack
$(MAKE) runtime
$(MAKE) ocamlopt.opt
$(MAKE) otherlibrariesopt
-# Installation
+# Core bootstrapping cycle
+.PHONY: coreboot
+coreboot:
+# Save the original bootstrap compiler
+ $(MAKE) backup
+# Promote the new compiler but keep the old runtime
+# This compiler runs on boot/ocamlrun and produces bytecode for
+# byterun/ocamlrun
+ $(MAKE) promote-cross
+# Rebuild ocamlc and ocamllex (run on byterun/ocamlrun)
+ $(MAKE) partialclean
+ $(MAKE) ocamlc ocamllex ocamltools
+# Rebuild the library (using byterun/ocamlrun ./ocamlc)
+ $(MAKE) library-cross
+# Promote the new compiler and the new runtime
+ $(MAKE) CAMLRUN=byterun/ocamlrun promote
+# Rebuild the core system
+ $(MAKE) partialclean
+ $(MAKE) core
+# Check if fixpoint reached
+ $(MAKE) compare
-COMPLIBDIR=$(LIBDIR)/compiler-libs
+# Recompile the system using the bootstrap compiler
-INSTALL_BINDIR=$(DESTDIR)$(BINDIR)
-INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
-INSTALL_COMPLIBDIR=$(DESTDIR)$(COMPLIBDIR)
-INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR)
-INSTALL_MANDIR=$(DESTDIR)$(MANDIR)
+.PHONY: all
+all: runtime
+ $(MAKE) coreall
+ $(MAKE) ocaml
+ $(MAKE) otherlibraries $(WITH_DEBUGGER) $(WITH_OCAMLDOC)
+# Bootstrap and rebuild the whole system.
+# The compilation of ocaml will fail if the runtime has changed.
+# Never mind, just do make bootstrap to reach fixpoint again.
+.PHONY: bootstrap
+bootstrap: coreboot
+ $(MAKE) all
+ $(MAKE) compare
+
+# Compile everything the first time
+
+.PHONY: world
+world: coldstart
+ $(MAKE) all
+
+# Compile also native code compiler and libraries, fast
+.PHONY: world.opt
+world.opt: coldstart
+ $(MAKE) opt.opt
+
+# FlexDLL sources missing error messages
+# Different git mechanism displayed depending on whether this source tree came
+# from a git clone or a source tarball.
+
+flexdll/Makefile:
+ @echo In order to bootstrap FlexDLL, you need to place the sources in
+ @echo flexdll.
+ @echo This can either be done by downloading a source tarball from
+ @echo \ http://alain.frisch.fr/flexdll.html
+ @if [ -d .git ]; then \
+ echo or by checking out the flexdll submodule with; \
+ echo \ git submodule update --init; \
+ else \
+ echo or by cloning the git repository; \
+ echo \ git clone https://github.com/alainfrisch/flexdll.git; \
+ fi
+ @false
+
+.PHONY: flexdll
+flexdll: flexdll/Makefile flexlink
+ $(MAKE) -C flexdll \
+ MSVC_DETECT=0 CHAINS=$(FLEXDLL_CHAIN) NATDYNLINK=false support
+
+# Bootstrapping flexlink - leaves a bytecode image of flexlink.exe in flexdll/
+.PHONY: flexlink
+flexlink: flexdll/Makefile
+ $(MAKE) -C byterun BOOTSTRAPPING_FLEXLINK=yes ocamlrun$(EXE)
+ cp byterun/ocamlrun$(EXE) boot/ocamlrun$(EXE)
+ $(MAKE) -C stdlib COMPILER=../boot/ocamlc stdlib.cma std_exit.cmo
+ cd stdlib && cp stdlib.cma std_exit.cmo *.cmi ../boot
+ $(MAKE) -C flexdll MSVC_DETECT=0 TOOLCHAIN=$(TOOLCHAIN) \
+ TOOLPREF=$(TOOLPREF) CHAINS=$(FLEXDLL_CHAIN) NATDYNLINK=false \
+ OCAMLOPT="../boot/ocamlrun ../boot/ocamlc -I ../boot" \
+ flexlink.exe
+ $(MAKE) -C byterun clean
+ $(MAKE) partialclean
+
+.PHONY: flexlink.opt
+flexlink.opt:
+ cd flexdll && \
+ mv flexlink.exe flexlink && \
+ $(MAKE) OCAML_FLEXLINK="../boot/ocamlrun ./flexlink" MSVC_DETECT=0 \
+ TOOLCHAIN=$(TOOLCHAIN) TOOLPREF=$(TOOLPREF) \
+ OCAMLOPT="../ocamlopt.opt -I ../stdlib" flexlink.exe && \
+ mv flexlink.exe flexlink.opt && \
+ mv flexlink flexlink.exe
+
+.PHONY: install-flexdll
+install-flexdll:
+ cat stdlib/camlheader flexdll/flexlink.exe > \
+ "$(INSTALL_BINDIR)/flexlink.exe"
+ifneq "$(filter-out mingw,$(TOOLCHAIN))" ""
+ cp flexdll/default$(filter-out _i386,_$(ARCH)).manifest \
+ "$(INSTALL_BINDIR)/"
+endif
+ if test -n "$(wildcard flexdll/flexdll_*.$(O))" ; then \
+ $(MKDIR) "$(INSTALL_FLEXDLL)" ; \
+ cp flexdll/flexdll_*.$(O) "$(INSTALL_FLEXDLL)" ; \
+ fi
+
+# Installation
+.PHONY: install
install:
- if test -d $(INSTALL_BINDIR); then : ; \
- else $(MKDIR) $(INSTALL_BINDIR); fi
- if test -d $(INSTALL_LIBDIR); then : ; \
- else $(MKDIR) $(INSTALL_LIBDIR); fi
- if test -d $(INSTALL_STUBLIBDIR); then : ; \
- else $(MKDIR) $(INSTALL_STUBLIBDIR); fi
- if test -d $(INSTALL_COMPLIBDIR); then : ; \
- else $(MKDIR) $(INSTALL_COMPLIBDIR); fi
- if test -d $(INSTALL_MANDIR)/man$(MANEXT); then : ; \
- else $(MKDIR) $(INSTALL_MANDIR)/man$(MANEXT); fi
- cp VERSION $(INSTALL_LIBDIR)/
- cd $(INSTALL_LIBDIR); rm -f \
- 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.byte$(EXE)
- cp ocaml $(INSTALL_BINDIR)/ocaml$(EXE)
- cd stdlib; $(MAKE) install
- 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 \
- typing/*.cmi typing/*.cmt typing/*.cmti \
- bytecomp/*.cmi bytecomp/*.cmt bytecomp/*.cmti \
- driver/*.cmi driver/*.cmt driver/*.cmti \
- toplevel/*.cmi toplevel/*.cmt toplevel/*.cmti $(INSTALL_COMPLIBDIR)
+ $(MKDIR) "$(INSTALL_BINDIR)"
+ $(MKDIR) "$(INSTALL_LIBDIR)"
+ $(MKDIR) "$(INSTALL_STUBLIBDIR)"
+ $(MKDIR) "$(INSTALL_COMPLIBDIR)"
+ cp VERSION "$(INSTALL_LIBDIR)"
+ $(MAKE) -C byterun install
+ cp ocaml "$(INSTALL_BINDIR)/ocaml$(EXE)"
+ cp ocamlc "$(INSTALL_BINDIR)/ocamlc.byte$(EXE)"
+ $(MAKE) -C stdlib install
+ cp lex/ocamllex "$(INSTALL_BINDIR)/ocamllex.byte$(EXE)"
+ cp yacc/ocamlyacc$(EXE) "$(INSTALL_BINDIR)/ocamlyacc$(EXE)"
+ cp utils/*.cmi utils/*.cmt utils/*.cmti utils/*.mli \
+ parsing/*.cmi parsing/*.cmt parsing/*.cmti parsing/*.mli \
+ typing/*.cmi typing/*.cmt typing/*.cmti typing/*.mli \
+ bytecomp/*.cmi bytecomp/*.cmt bytecomp/*.cmti bytecomp/*.mli \
+ driver/*.cmi driver/*.cmt driver/*.cmti driver/*.mli \
+ toplevel/*.cmi toplevel/*.cmt toplevel/*.cmti toplevel/*.mli \
+ "$(INSTALL_COMPLIBDIR)"
cp compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \
compilerlibs/ocamltoplevel.cma $(BYTESTART) $(TOPLEVELSTART) \
- $(INSTALL_COMPLIBDIR)
- cp expunge $(INSTALL_LIBDIR)/expunge$(EXE)
- cp toplevel/topdirs.cmi $(INSTALL_LIBDIR)
- cd tools; $(MAKE) install
- -cd man; $(MAKE) install
+ "$(INSTALL_COMPLIBDIR)"
+ cp expunge "$(INSTALL_LIBDIR)/expunge$(EXE)"
+ cp toplevel/topdirs.cmi toplevel/topdirs.cmt toplevel/topdirs.cmti \
+ toplevel/topdirs.mli "$(INSTALL_LIBDIR)"
+ $(MAKE) -C tools install
+ifeq "$(UNIX_OR_WIN32)" "unix" # Install manual pages only on Unix
+ $(MKDIR) "$(INSTALL_MANDIR)/man$(MANEXT)"
+ -$(MAKE) -C man install
+endif
for i in $(OTHERLIBRARIES); do \
- (cd otherlibs/$$i; $(MAKE) install) || exit $$?; \
+ $(MAKE) -C otherlibs/$$i install || exit $$?; \
done
- 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 -n "$(WITH_OCAMLDOC)"; then \
+ $(MAKE) -C ocamldoc install; \
+ fi
+ if test -n "$(WITH_DEBUGGER)"; then \
+ $(MAKE) -C debugger install; \
+ fi
+ifeq "$(UNIX_OR_WIN32)" "win32"
+ if test -n "$(FLEXDLL_SUBMODULE_PRESENT)"; then \
+ $(MAKE) install-flexdll; \
+ fi
+endif
+ cp config/Makefile "$(INSTALL_LIBDIR)/Makefile.config"
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
+ cd "$(INSTALL_BINDIR)"; \
+ $(LN) ocamlc.byte$(EXE) ocamlc$(EXE); \
+ $(LN) ocamllex.byte$(EXE) ocamllex$(EXE); \
+ fi
# Installation of the native-code compiler
+.PHONY: installopt
installopt:
- cd asmrun; $(MAKE) install
- cp ocamlopt $(INSTALL_BINDIR)/ocamlopt.byte$(EXE)
- cd stdlib; $(MAKE) installopt
+ $(MAKE) -C asmrun install
+ cp ocamlopt "$(INSTALL_BINDIR)/ocamlopt.byte$(EXE)"
+ $(MAKE) -C stdlib installopt
cp middle_end/*.cmi middle_end/*.cmt middle_end/*.cmti \
- $(INSTALL_COMPLIBDIR)
+ middle_end/*.mli \
+ "$(INSTALL_COMPLIBDIR)"
cp middle_end/base_types/*.cmi middle_end/base_types/*.cmt \
- middle_end/base_types/*.cmti $(INSTALL_COMPLIBDIR)
- cp asmcomp/*.cmi asmcomp/*.cmt asmcomp/*.cmti $(INSTALL_COMPLIBDIR)
- cp compilerlibs/ocamloptcomp.cma $(OPTSTART) $(INSTALL_COMPLIBDIR)
- if test -n "$(WITH_OCAMLDOC)"; then (cd ocamldoc; $(MAKE) installopt); \
- else :; fi
- for i in $(OTHERLIBRARIES); \
- do (cd otherlibs/$$i; $(MAKE) installopt) || exit $$?; done
+ middle_end/base_types/*.cmti middle_end/base_types/*.mli \
+ "$(INSTALL_COMPLIBDIR)"
+ cp asmcomp/*.cmi asmcomp/*.cmt asmcomp/*.cmti asmcomp/*.mli \
+ "$(INSTALL_COMPLIBDIR)"
+ cp compilerlibs/ocamloptcomp.cma $(OPTSTART) "$(INSTALL_COMPLIBDIR)"
+ if test -n "$(WITH_OCAMLDOC)"; then \
+ $(MAKE) -C ocamldoc installopt; \
+ fi
+ for i in $(OTHERLIBRARIES); do \
+ $(MAKE) -C otherlibs/$$i installopt || exit $$?; \
+ done
if test -f ocamlopt.opt ; then $(MAKE) installoptopt; else \
- cd $(INSTALL_BINDIR); ln -sf ocamlopt.byte$(EXE) ocamlopt$(EXE); fi
- cd tools; $(MAKE) installopt
+ cd "$(INSTALL_BINDIR)"; \
+ $(LN) ocamlc.byte$(EXE) ocamlc$(EXE); \
+ $(LN) ocamlopt.byte$(EXE) ocamlopt$(EXE); \
+ $(LN) ocamllex.byte$(EXE) ocamllex$(EXE); \
+ fi
+ $(MAKE) -C tools installopt
+ if test -f ocamlopt.opt -a -f flexdll/flexlink.opt ; then \
+ cp -f flexdll/flexlink.opt "$(INSTALL_BINDIR)/flexlink$(EXE)" ; \
+ fi
+
+
+.PHONY: installoptopt
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 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) ocamlc.opt$(EXE) ocamlc$(EXE); \
+ $(LN) ocamlopt.opt$(EXE) ocamlopt$(EXE); \
+ $(LN) 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 \
- compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.a \
- compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.a \
- $(BYTESTART:.cmo=.cmx) $(BYTESTART:.cmo=.o) \
- $(OPTSTART:.cmo=.cmx) $(OPTSTART:.cmo=.o) \
- $(INSTALL_COMPLIBDIR)
- if test -f ocamlnat ; then \
- cp ocamlnat $(INSTALL_BINDIR)/ocamlnat$(EXE); \
- cp toplevel/opttopdirs.cmi $(INSTALL_LIBDIR); \
+ driver/*.cmx asmcomp/*.cmx "$(INSTALL_COMPLIBDIR)"
+ cp compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.$(A) \
+ compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.$(A) \
+ compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.$(A) \
+ $(BYTESTART:.cmo=.cmx) $(BYTESTART:.cmo=.$(O)) \
+ $(OPTSTART:.cmo=.cmx) $(OPTSTART:.cmo=.$(O)) \
+ "$(INSTALL_COMPLIBDIR)"
+ if test -f ocamlnat$(EXE) ; then \
+ cp ocamlnat$(EXE) "$(INSTALL_BINDIR)/ocamlnat$(EXE)"; \
+ cp toplevel/opttopdirs.cmi "$(INSTALL_LIBDIR)"; \
cp compilerlibs/ocamlopttoplevel.cmxa \
- compilerlibs/ocamlopttoplevel.a \
- $(OPTTOPLEVELSTART:.cmo=.cmx) $(OPTTOPLEVELSTART:.cmo=.o) \
- $(INSTALL_COMPLIBDIR); \
+ compilerlibs/ocamlopttoplevel.$(A) \
+ $(OPTTOPLEVELSTART:.cmo=.cmx) $(OPTTOPLEVELSTART:.cmo=.$(O)) \
+ "$(INSTALL_COMPLIBDIR)"; \
fi
- cd $(INSTALL_COMPLIBDIR) && $(RANLIB) ocamlcommon.a ocamlbytecomp.a \
- ocamloptcomp.a
+ cd "$(INSTALL_COMPLIBDIR)" && \
+ $(RANLIB) ocamlcommon.$(A) ocamlbytecomp.$(A) ocamloptcomp.$(A)
+
+# Installation of the *.ml sources of compiler-libs
+.PHONY: install-compiler-sources
+install-compiler-sources:
+ cp utils/*.ml parsing/*.ml typing/*.ml bytecomp/*.ml driver/*.ml \
+ toplevel/*.ml middle_end/*.ml middle_end/base_types/*.ml \
+ asmcomp/*.ml $(INSTALL_COMPLIBDIR)
# Run all tests
+.PHONY: tests
tests: opt.opt
cd testsuite; $(MAKE) clean && $(MAKE) all
-# The clean target
+# Make clean in the test suite
+
+.PHONY: clean
+clean::
+ $(MAKE) -C testsuite clean
+# Build the manual latex files from the etex source files
+# (see manual/README.md)
+.PHONY: manual-pregen
+manual-pregen: opt.opt
+ cd manual; $(MAKE) clean && $(MAKE) pregen-etex
+
+# The clean target
clean:: partialclean
# Shared parts of the system
compilerlibs/ocamlcommon.cma: $(COMMON)
- $(CAMLC) -a -linkall -o $@ $(COMMON)
+ $(CAMLC) -a -linkall -o $@ $^
partialclean::
rm -f compilerlibs/ocamlcommon.cma
# The bytecode compiler
compilerlibs/ocamlbytecomp.cma: $(BYTECOMP)
- $(CAMLC) -a -o $@ $(BYTECOMP)
+ $(CAMLC) -a -o $@ $^
partialclean::
rm -f compilerlibs/ocamlbytecomp.cma
ocamlc: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART)
- $(CAMLC) $(LINKFLAGS) -compat-32 -o ocamlc \
- compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \
- $(BYTESTART)
+ $(CAMLC) $(LINKFLAGS) -compat-32 -o $@ $^
+
+partialclean::
+ rm -rf ocamlc
# The native-code compiler
compilerlibs/ocamloptcomp.cma: $(MIDDLE_END) $(ASMCOMP)
- $(CAMLC) -a -o $@ $(MIDDLE_END) $(ASMCOMP)
+ $(CAMLC) -a -o $@ $^
partialclean::
rm -f compilerlibs/ocamloptcomp.cma
ocamlopt: compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma \
compilerlibs/ocamlbytecomp.cma $(OPTSTART)
- $(CAMLC) $(LINKFLAGS) -o ocamlopt \
- compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma \
- compilerlibs/ocamlbytecomp.cma $(OPTSTART)
+ $(CAMLC) $(LINKFLAGS) -o $@ $^
partialclean::
rm -f ocamlopt
# The toplevel
compilerlibs/ocamltoplevel.cma: $(TOPLEVEL)
- $(CAMLC) -a -o $@ $(TOPLEVEL)
+ $(CAMLC) -a -o $@ $^
partialclean::
rm -f compilerlibs/ocamltoplevel.cma
-ocaml: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \
- compilerlibs/ocamltoplevel.cma $(TOPLEVELSTART) expunge
- $(CAMLC) $(LINKFLAGS) -linkall -o ocaml.tmp \
- compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \
- compilerlibs/ocamltoplevel.cma $(TOPLEVELSTART)
- - $(CAMLRUN) ./expunge ocaml.tmp ocaml $(PERVASIVES)
- rm -f ocaml.tmp
+ocaml_dependencies := \
+ compilerlibs/ocamlcommon.cma \
+ compilerlibs/ocamlbytecomp.cma \
+ compilerlibs/ocamltoplevel.cma $(TOPLEVELSTART)
+
+.INTERMEDIATE: ocaml.tmp
+ocaml.tmp: $(ocaml_dependencies)
+ $(CAMLC) $(LINKFLAGS) -linkall -o $@ $^
+
+ocaml: expunge ocaml.tmp
+ - $(CAMLRUN) $^ $@ $(PERVASIVES)
partialclean::
rm -f ocaml
-RUNTOP=./byterun/ocamlrun ./ocaml -nostdlib -I stdlib -noinit $(TOPFLAGS)
-NATRUNTOP=./ocamlnat -nostdlib -I stdlib -noinit $(TOPFLAGS)
-
+.PHONY: runtop
runtop:
+ifeq "$(UNIX_OR_WIN32)" "unix"
$(MAKE) runtime
$(MAKE) coreall
$(MAKE) ocaml
- @rlwrap --help 2>/dev/null && rlwrap $(RUNTOP) || $(RUNTOP)
+else
+ $(MAKE) core
+ $(MAKE) ocaml
+endif
+ @rlwrap --help 2>/dev/null && $(EXTRAPATH) rlwrap $(RUNTOP) ||\
+ $(EXTRAPATH) $(RUNTOP)
+.PHONY: natruntop
natruntop:
$(MAKE) runtime
$(MAKE) coreall
$(MAKE) opt.opt
$(MAKE) ocamlnat
- @rlwrap --help 2>/dev/null && rlwrap $(NATRUNTOP) || $(NATRUNTOP)
+ @rlwrap --help 2>/dev/null && $(EXTRAPATH) rlwrap $(NATRUNTOP) ||\
+ $(EXTRAPATH) $(NATRUNTOP)
-# The native toplevel
-
-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 $@ $^
-
-partialclean::
- rm -f ocamlnat
-
-toplevel/opttoploop.cmx: otherlibs/dynlink/dynlink.cmxa
+# Native dynlink
otherlibs/dynlink/dynlink.cmxa: otherlibs/dynlink/natdynlink.ml
- cd otherlibs/dynlink && $(MAKE) allopt
-
-# The configuration file
-
-utils/config.ml: utils/config.mlp config/Makefile
- @rm -f utils/config.ml
- sed -e 's|%%LIBDIR%%|$(LIBDIR)|' \
- -e 's|%%BYTERUN%%|$(BINDIR)/ocamlrun|' \
- -e 's|%%CCOMPTYPE%%|cc|' \
- -e 's|%%BYTECC%%|$(BYTECC) $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS)|' \
- -e 's|%%NATIVECC%%|$(NATIVECC) $(NATIVECCCOMPOPTS)|' \
- -e '/c_compiler =/s| -Werror||' \
- -e 's|%%PACKLD%%|$(PACKLD)|' \
- -e 's|%%BYTECCLIBS%%|$(BYTECCLIBS)|' \
- -e 's|%%NATIVECCLIBS%%|$(NATIVECCLIBS)|' \
- -e 's|%%RANLIBCMD%%|$(RANLIBCMD)|' \
- -e 's|%%ARCMD%%|$(ARCMD)|' \
- -e 's|%%CC_PROFILE%%|$(CC_PROFILE)|' \
- -e 's|%%ARCH%%|$(ARCH)|' \
- -e 's|%%MODEL%%|$(MODEL)|' \
- -e 's|%%SYSTEM%%|$(SYSTEM)|' \
- -e 's|%%EXT_OBJ%%|.o|' \
- -e 's|%%EXT_ASM%%|.s|' \
- -e 's|%%EXT_LIB%%|.a|' \
- -e 's|%%EXT_DLL%%|$(EXT_DLL)|' \
- -e 's|%%SYSTHREAD_SUPPORT%%|$(SYSTHREAD_SUPPORT)|' \
- -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::
- rm -f utils/config.ml
-
-beforedepend:: utils/config.ml
+ $(MAKE) -C otherlibs/dynlink allopt
# The parser
parsing/parser.mli parsing/parser.ml: parsing/parser.mly
- $(CAMLYACC) $(YACCFLAGS) parsing/parser.mly
+ $(CAMLYACC) $(YACCFLAGS) $<
partialclean::
rm -f parsing/parser.mli parsing/parser.ml parsing/parser.output
# The lexer
parsing/lexer.ml: parsing/lexer.mll
- $(CAMLLEX) parsing/lexer.mll
+ $(CAMLLEX) $<
partialclean::
rm -f parsing/lexer.ml
# Shared parts of the system compiled with the native-code compiler
compilerlibs/ocamlcommon.cmxa: $(COMMON:.cmo=.cmx)
- $(CAMLOPT) -a -linkall -o $@ $(COMMON:.cmo=.cmx)
+ $(CAMLOPT) -a -linkall -o $@ $^
partialclean::
- rm -f compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.a
+ rm -f compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.$(A)
# The bytecode compiler compiled with the native-code compiler
compilerlibs/ocamlbytecomp.cmxa: $(BYTECOMP:.cmo=.cmx)
- $(CAMLOPT) -a -o $@ $(BYTECOMP:.cmo=.cmx)
+ $(CAMLOPT) -a $(OCAML_NATDYNLINKOPTS) -o $@ $^
partialclean::
- rm -f compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.a
+ rm -f compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.$(A)
ocamlc.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \
$(BYTESTART:.cmo=.cmx)
- $(CAMLOPT) $(LINKFLAGS) -ccopt "$(BYTECCLINKOPTS)" -o ocamlc.opt \
- compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \
- $(BYTESTART:.cmo=.cmx) -cclib "$(BYTECCLIBS)"
+ $(CAMLOPT) $(LINKFLAGS) $(OCAML_BYTECCLINKOPTS) -o $@ \
+ $^ -cclib "$(BYTECCLIBS)"
partialclean::
rm -f ocamlc.opt
# The native-code compiler compiled with itself
compilerlibs/ocamloptcomp.cmxa: $(MIDDLE_END:.cmo=.cmx) $(ASMCOMP:.cmo=.cmx)
- $(CAMLOPT) -a -o $@ $(MIDDLE_END:.cmo=.cmx) $(ASMCOMP:.cmo=.cmx)
+ $(CAMLOPT) -a -o $@ $^
partialclean::
- rm -f compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.a
+ 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)
+ $(CAMLOPT) $(LINKFLAGS) -o $@ $^
partialclean::
rm -f ocamlopt.opt
$(COMMON:.cmo=.cmx) $(BYTECOMP:.cmo=.cmx) $(MIDDLE_END:.cmo=.cmx) \
$(ASMCOMP:.cmo=.cmx): ocamlopt
-# The numeric opcodes
-
-bytecomp/opcodes.ml: byterun/caml/instruct.h
- sed -n -e '/^enum/p' -e 's/,//g' -e '/^ /p' byterun/caml/instruct.h | \
- awk -f tools/make-opcodes > bytecomp/opcodes.ml
-
-partialclean::
- rm -f bytecomp/opcodes.ml
-
-beforedepend:: bytecomp/opcodes.ml
-
# The predefined exceptions and primitives
byterun/primitives:
- cd byterun; $(MAKE) primitives
+ $(MAKE) -C byterun primitives
bytecomp/runtimedef.ml: byterun/primitives byterun/caml/fail.h
(echo 'let builtin_exceptions = [|'; \
- sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$$| \1;|p' \
- byterun/caml/fail.h; \
+ cat byterun/caml/fail.h | tr -d '\r' | \
+ sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$$| \1;|p'; \
echo '|]'; \
echo 'let builtin_primitives = [|'; \
sed -e 's/.*/ "&";/' byterun/primitives; \
- echo '|]') > bytecomp/runtimedef.ml
+ echo '|]') > $@
partialclean::
rm -f bytecomp/runtimedef.ml
# Choose the right machine-dependent files
-asmcomp/arch.ml: asmcomp/$(ARCH_OCAMLOPT)/arch.ml
- ln -s $(ARCH_OCAMLOPT)/arch.ml asmcomp/arch.ml
+asmcomp/arch.ml: asmcomp/$(ARCH)/arch.ml
+ cd asmcomp; $(LN) $(ARCH)/arch.ml .
-asmcomp/proc.ml: asmcomp/$(ARCH_OCAMLOPT)/proc.ml
- ln -s $(ARCH_OCAMLOPT)/proc.ml asmcomp/proc.ml
+asmcomp/proc.ml: asmcomp/$(ARCH)/proc.ml
+ cd asmcomp; $(LN) $(ARCH)/proc.ml .
-asmcomp/selection.ml: asmcomp/$(ARCH_OCAMLOPT)/selection.ml
- ln -s $(ARCH_OCAMLOPT)/selection.ml asmcomp/selection.ml
+asmcomp/selection.ml: asmcomp/$(ARCH)/selection.ml
+ cd asmcomp; $(LN) $(ARCH)/selection.ml .
-asmcomp/CSE.ml: asmcomp/$(ARCH_OCAMLOPT)/CSE.ml
- ln -s $(ARCH_OCAMLOPT)/CSE.ml asmcomp/CSE.ml
+asmcomp/CSE.ml: asmcomp/$(ARCH)/CSE.ml
+ cd asmcomp; $(LN) $(ARCH)/CSE.ml .
-asmcomp/reload.ml: asmcomp/$(ARCH_OCAMLOPT)/reload.ml
- ln -s $(ARCH_OCAMLOPT)/reload.ml asmcomp/reload.ml
+asmcomp/reload.ml: asmcomp/$(ARCH)/reload.ml
+ cd asmcomp; $(LN) $(ARCH)/reload.ml .
-asmcomp/scheduling.ml: asmcomp/$(ARCH_OCAMLOPT)/scheduling.ml
- ln -s $(ARCH_OCAMLOPT)/scheduling.ml asmcomp/scheduling.ml
+asmcomp/scheduling.ml: asmcomp/$(ARCH)/scheduling.ml
+ cd asmcomp; $(LN) $(ARCH)/scheduling.ml .
# Preprocess the code emitters
-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/$(ARCH_OCAMLOPT)/emit.mlp \
- >>asmcomp/emit.ml \
- || { rm -f asmcomp/emit.ml; exit 2; }
+asmcomp/emit.ml: asmcomp/$(ARCH)/emit.mlp tools/cvt_emit
+ echo \# 1 \"$(ARCH)/emit.mlp\" > $@
+ $(CAMLRUN) tools/cvt_emit < $< >> $@ \
+ || { rm -f $@; exit 2; }
+
+partialclean::
+ rm -f asmcomp/emit.ml
+
+beforedepend:: asmcomp/emit.ml
tools/cvt_emit: tools/cvt_emit.mll
- cd tools && $(MAKE) cvt_emit
+ $(MAKE) -C tools cvt_emit
# The "expunge" utility
expunge: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \
toplevel/expunge.cmo
- $(CAMLC) $(LINKFLAGS) -o expunge compilerlibs/ocamlcommon.cma \
- compilerlibs/ocamlbytecomp.cma toplevel/expunge.cmo
+ $(CAMLC) $(LINKFLAGS) -o $@ $^
partialclean::
rm -f expunge
# The runtime system for the bytecode compiler
-runtime:
- cd byterun; $(MAKE) all
- if test -f stdlib/libcamlrun.a; then :; else \
- ln -s ../byterun/libcamlrun.a stdlib/libcamlrun.a; fi
+.PHONY: runtime
+runtime: stdlib/libcamlrun.$(A)
+.PHONY: makeruntime
+makeruntime:
+ $(MAKE) -C byterun $(BOOT_FLEXLINK_CMD) all
+byterun/libcamlrun.$(A): makeruntime ;
+stdlib/libcamlrun.$(A): byterun/libcamlrun.$(A)
+ cd stdlib; $(LN) ../byterun/libcamlrun.$(A) .
clean::
- cd byterun; $(MAKE) clean
- rm -f stdlib/libcamlrun.a
- rm -f stdlib/caml
+ $(MAKE) -C byterun clean
+ rm -f stdlib/libcamlrun.$(A)
+.PHONY: alldepend
alldepend::
- cd byterun; $(MAKE) depend
+ $(MAKE) -C byterun depend
# The runtime system for the native-code compiler
-runtimeopt: makeruntimeopt
- cp asmrun/libasmrun.a stdlib/libasmrun.a
+.PHONY: runtimeopt
+runtimeopt: stdlib/libasmrun.$(A)
+.PHONY: makeruntimeopt
makeruntimeopt:
- cd asmrun; $(MAKE) all
-
+ $(MAKE) -C asmrun $(BOOT_FLEXLINK_CMD) all
+asmrun/libasmrun.$(A): makeruntimeopt ;
+stdlib/libasmrun.$(A): asmrun/libasmrun.$(A)
+ cp $< $@
clean::
- cd asmrun; $(MAKE) clean
- rm -f stdlib/libasmrun.a
-
+ $(MAKE) -C asmrun clean
+ rm -f stdlib/libasmrun.$(A)
alldepend::
- cd asmrun; $(MAKE) depend
+ $(MAKE) -C asmrun depend
-# The library
+# The standard library
+.PHONY: library
library: ocamlc
- cd stdlib; $(MAKE) all
+ $(MAKE) -C stdlib $(BOOT_FLEXLINK_CMD) all
+.PHONY: library-cross
library-cross:
- cd stdlib; $(MAKE) CAMLRUN=../byterun/ocamlrun all
+ $(MAKE) -C stdlib $(BOOT_FLEXLINK_CMD) CAMLRUN=../byterun/ocamlrun all
+.PHONY: libraryopt
libraryopt:
- cd stdlib; $(MAKE) allopt
+ $(MAKE) -C stdlib $(BOOT_FLEXLINK_CMD) allopt
partialclean::
- cd stdlib; $(MAKE) clean
+ $(MAKE) -C stdlib clean
alldepend::
- cd stdlib; $(MAKE) depend
+ $(MAKE) -C stdlib depend
# The lexer and parser generators
+.PHONY: ocamllex
ocamllex: ocamlyacc ocamlc
- cd lex; $(MAKE) all
+ $(MAKE) -C lex all
+.PHONY: ocamllex.opt
ocamllex.opt: ocamlopt
- cd lex; $(MAKE) allopt
+ $(MAKE) -C lex allopt
partialclean::
- cd lex; $(MAKE) clean
+ $(MAKE) -C lex clean
alldepend::
- cd lex; $(MAKE) depend
+ $(MAKE) -C lex depend
+.PHONY: ocamlyacc
ocamlyacc:
- cd yacc; $(MAKE) all
+ $(MAKE) -C yacc $(BOOT_FLEXLINK_CMD) all
clean::
- cd yacc; $(MAKE) clean
+ $(MAKE) -C yacc clean
# OCamldoc
+.PHONY: ocamldoc
ocamldoc: ocamlc ocamlyacc ocamllex otherlibraries
- cd ocamldoc && $(MAKE) all
+ $(MAKE) -C ocamldoc all
+.PHONY: ocamldoc.opt
ocamldoc.opt: ocamlc.opt ocamlyacc ocamllex
- cd ocamldoc && $(MAKE) opt.opt
+ $(MAKE) -C ocamldoc opt.opt
# Documentation
+.PHONY: html_doc
html_doc: ocamldoc
- make -C ocamldoc html_doc
+ $(MAKE) -C ocamldoc $@
@echo "documentation is in ./ocamldoc/stdlib_html/"
partialclean::
- cd ocamldoc && $(MAKE) clean
+ $(MAKE) -C ocamldoc clean
alldepend::
- cd ocamldoc && $(MAKE) depend
+ $(MAKE) -C ocamldoc depend
# The extra libraries
+.PHONY: otherlibraries
otherlibraries: ocamltools
for i in $(OTHERLIBRARIES); do \
- (cd otherlibs/$$i; $(MAKE) all) || exit $$?; \
+ ($(MAKE) -C otherlibs/$$i all) || exit $$?; \
done
+.PHONY: otherlibrariesopt
otherlibrariesopt:
for i in $(OTHERLIBRARIES); do \
- (cd otherlibs/$$i; $(MAKE) allopt) || exit $$?; \
+ ($(MAKE) -C otherlibs/$$i allopt) || exit $$?; \
done
partialclean::
for i in $(OTHERLIBRARIES); do \
- (cd otherlibs/$$i && $(MAKE) partialclean); \
+ ($(MAKE) -C otherlibs/$$i partialclean); \
done
clean::
- for i in $(OTHERLIBRARIES); do (cd otherlibs/$$i && $(MAKE) clean); done
+ for i in $(OTHERLIBRARIES); do \
+ ($(MAKE) -C otherlibs/$$i clean); \
+ done
alldepend::
- for i in $(OTHERLIBRARIES); do (cd otherlibs/$$i; $(MAKE) depend); done
+ for i in $(OTHERLIBRARIES); do \
+ ($(MAKE) -C otherlibs/$$i depend); \
+ done
# The replay debugger
+.PHONY: ocamldebugger
ocamldebugger: ocamlc ocamlyacc ocamllex otherlibraries
- cd debugger; $(MAKE) all
+ $(MAKE) -C debugger all
partialclean::
- cd debugger; $(MAKE) clean
+ $(MAKE) -C debugger clean
alldepend::
- cd debugger; $(MAKE) depend
+ $(MAKE) -C debugger depend
# Check that the stack limit is reasonable.
-
+ifeq "$(UNIX_OR_WIN32)" "unix"
+.PHONY: checkstack
checkstack:
- @if $(MKEXE) -o tools/checkstack$(EXE) tools/checkstack.c; \
+ if $(MKEXE) -o tools/checkstack$(EXE) tools/checkstack.c; \
then tools/checkstack$(EXE); \
else :; \
fi
- @rm -f tools/checkstack
+ rm -f tools/checkstack$(EXE)
+endif
+
+# Lint @since and @deprecated annotations
+
+.PHONY: lintapidiff
+lintapidiff:
+ $(MAKE) -C tools lintapidiff.opt
+ git ls-files -- 'otherlibs/*/*.mli' 'stdlib/*.mli' |\
+ grep -Ev internal\|obj\|spacetime\|stdLabels\|moreLabels |\
+ tools/lintapidiff.opt $(shell git tag|grep '^[0-9]*.[0-9]*.[0-9]*$$'|grep -v '^[12].')
# Make clean in the test suite
cd testsuite; $(MAKE) clean
# Make MacOS X package
-
+ifeq "$(UNIX_OR_WIN32)" "unix"
+.PHONY: package-macosx
package-macosx:
sudo rm -rf package-macosx/root
$(MAKE) PREFIX="`pwd`"/package-macosx/root install
clean::
rm -rf package-macosx/*.pkg package-macosx/*.dmg
+endif
+
+# The middle end (whose .cma library is currently only used for linking
+# the "ocamlobjinfo" program, since we cannot depend on the whole native code
+# compiler for "make world" and the list of dependencies for
+# asmcomp/export_info.cmo is long).
+
+compilerlibs/ocamlmiddleend.cma: $(MIDDLE_END)
+ $(CAMLC) -a -o $@ $^
+compilerlibs/ocamlmiddleend.cmxa: $(MIDDLE_END:%.cmo=%.cmx)
+ $(CAMLOPT) -a -o $@ $^
+partialclean::
+ rm -f compilerlibs/ocamlmiddleend.cma \
+ compilerlibs/ocamlmiddleend.cmxa \
+ compilerlibs/ocamlmiddleend.$(A)
+
+# Tools
+
+.PHONY: ocamltools
+ocamltools: ocamlc ocamlyacc ocamllex asmcomp/cmx_format.cmi \
+ asmcomp/printclambda.cmo compilerlibs/ocamlmiddleend.cma \
+ asmcomp/export_info.cmo
+ $(MAKE) -C tools all
+
+.PHONY: ocamltoolsopt
+ocamltoolsopt: ocamlopt
+ $(MAKE) -C tools opt
+
+.PHONY: ocamltoolsopt.opt
+ocamltoolsopt.opt: ocamlc.opt ocamlyacc ocamllex.opt asmcomp/cmx_format.cmi \
+ asmcomp/printclambda.cmx compilerlibs/ocamlmiddleend.cmxa \
+ asmcomp/export_info.cmx
+ $(MAKE) -C tools opt.opt
+
+partialclean::
+ $(MAKE) -C tools clean
+
+alldepend::
+ $(MAKE) -C tools depend
+
+## Test compilation of backend-specific parts
+
+partialclean::
+ rm -f $(ARCH_SPECIFIC)
+
+beforedepend:: $(ARCH_SPECIFIC)
+
+# This rule provides a quick way to check that machine-dependent
+# files compiles fine for a foreign architecture (passed as ARCH=xxx).
+
+.PHONY: check_arch
+check_arch:
+ @echo "========= CHECKING asmcomp/$(ARCH) =============="
+ @rm -f $(ARCH_SPECIFIC) asmcomp/emit.ml asmcomp/*.cm*
+ @$(MAKE) compilerlibs/ocamloptcomp.cma \
+ >/dev/null
+ @rm -f $(ARCH_SPECIFIC) asmcomp/emit.ml asmcomp/*.cm*
+
+.PHONY: check_all_arches
+check_all_arches:
+ @STATUS=0; \
+ for i in $(ARCHES); do \
+ $(MAKE) --no-print-directory check_arch ARCH=$$i || STATUS=1; \
+ done; \
+ exit $$STATUS
+
+# 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
+
+# The native toplevel
+
+compilerlibs/ocamlopttoplevel.cmxa: $(OPTTOPLEVEL:.cmo=.cmx)
+ $(CAMLOPT) -a -o $@ $^
+partialclean::
+ rm -f compilerlibs/ocamlopttoplevel.cmxa
+
+# When the native toplevel executable has an extension (e.g. ".exe"),
+# provide a phony 'ocamlnat' synonym
+
+ifneq ($(EXE),)
+.PHONY: ocamlnat
+ocamlnat: ocamlnat$(EXE)
+endif
+
+ocamlnat$(EXE): compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \
+ compilerlibs/ocamlbytecomp.cmxa \
+ compilerlibs/ocamlopttoplevel.cmxa \
+ $(OPTTOPLEVELSTART:.cmo=.cmx)
+ $(CAMLOPT) $(LINKFLAGS) -linkall -o $@ $^
+
+partialclean::
+ rm -f ocamlnat$(EXE)
+
+toplevel/opttoploop.cmx: otherlibs/dynlink/dynlink.cmxa
+
+# The numeric opcodes
+
+bytecomp/opcodes.ml: byterun/caml/instruct.h tools/make_opcodes
+ $(CAMLRUN) tools/make_opcodes -opcodes < $< > $@
+
+tools/make_opcodes: tools/make_opcodes.mll
+ $(MAKE) -C tools make_opcodes
+
+partialclean::
+ rm -f bytecomp/opcodes.ml
+
+beforedepend:: bytecomp/opcodes.ml
# Default rules
partialclean::
for d in utils parsing typing bytecomp asmcomp middle_end \
- middle_end/base_types driver toplevel tools; \
- do rm -f $$d/*.cm[ioxt] $$d/*.cmti $$d/*.annot $$d/*.[so] $$d/*~; done
+ middle_end/base_types driver toplevel tools; do \
+ rm -f $$d/*.cm[ioxt] $$d/*.cmti $$d/*.annot $$d/*.$(S) \
+ $$d/*.$(O) $$d/*.$(SO) $d/*~; \
+ done
rm -f *~
+.PHONY: depend
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) $(DEPFLAGS) -native \
+ $(CAMLDEP) -slash $(DEPFLAGS) -native \
-impl driver/compdynlink.mlopt >> .depend
- $(CAMLDEP) $(DEPFLAGS) -bytecode \
+ $(CAMLDEP) -slash $(DEPFLAGS) -bytecode \
-impl driver/compdynlink.mlbyte >> .depend
alldepend:: depend
-distclean:
- $(MAKE) clean
- rm -f boot/ocamlrun boot/ocamlrun.exe boot/camlheader boot/ocamlyacc \
- boot/*.cm* boot/libcamlrun.a
+.PHONY: distclean
+distclean: clean
+ 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
rm -f tools/*.bak
rm -f ocaml ocamlc
rm -f testsuite/_log
-.PHONY: all backup bootstrap checkstack clean
-.PHONY: partialclean beforedepend alldepend cleanboot coldstart
-.PHONY: compare core coreall
-.PHONY: coreboot defaultentry depend distclean install installopt
-.PHONY: library library-cross libraryopt
-.PHONY: ocamldebugger ocamldoc
-.PHONY: ocamldoc.opt ocamllex ocamllex.opt ocamltools ocamltoolsopt
-.PHONY: ocamltoolsopt.opt ocamlyacc opt-core opt opt.opt otherlibraries
-.PHONY: otherlibrariesopt package-macosx promote promote-cross
-.PHONY: restore runtime runtimeopt makeruntimeopt world world.opt
-
include .depend
#* *
#**************************************************************************
-# The main Makefile
-
-include Makefile.shared
-
-# For users who don't read the INSTALL file
-defaultentry:
- @echo "Please refer to the instructions in file README.win32.adoc."
-
-FLEXDLL_SUBMODULE_PRESENT:=$(wildcard flexdll/Makefile)
-ifeq "$(FLEXDLL_SUBMODULE_PRESENT)" ""
- BOOT_FLEXLINK_CMD=
-else
- BOOT_FLEXLINK_CMD=FLEXLINK_CMD="../boot/ocamlrun ../flexdll/flexlink.exe"
- CAMLOPT:=OCAML_FLEXLINK="boot/ocamlrun flexdll/flexlink.exe" $(CAMLOPT)
-endif
-
-# FlexDLL sources missing error messages
-# Different git mechanism displayed depending on whether this source tree came
-# from a git clone or a source tarball.
-
-flexdll/Makefile:
- @echo In order to bootstrap FlexDLL, you need to place the sources in
- @echo flexdll.
- @echo This can either be done by downloading a source tarball from
- @echo \ http://alain.frisch.fr/flexdll.html
- @if [ -d .git ]; then \
- echo or by checking out the flexdll submodule with; \
- echo \ git submodule update --init; \
- else \
- echo or by cloning the git repository; \
- echo \ git clone https://github.com/alainfrisch/flexdll.git; \
- fi
- @false
-
-# Bootstrapping FlexDLL - leaves a bytecode image of flexlink.exe in flexdll/
-flexdll: flexdll/Makefile
- cd byterun && $(MAKEREC) BOOTSTRAPPING_FLEXLINK=yes ocamlrun$(EXE)
- cp byterun/ocamlrun.exe boot/ocamlrun.exe
- cd stdlib && $(MAKEREC) COMPILER=../boot/ocamlc stdlib.cma std_exit.cmo
- cd stdlib && cp stdlib.cma std_exit.cmo *.cmi ../boot
- cd flexdll && \
- $(MAKECMD) MSVC_DETECT=0 TOOLCHAIN=$(TOOLCHAIN) TOOLPREF=$(TOOLPREF) \
- CHAINS=$(FLEXDLL_CHAIN) NATDYNLINK=false \
- OCAMLOPT="../boot/ocamlrun ../boot/ocamlc -I ../boot" \
- flexlink.exe support
- cd byterun && $(MAKEREC) clean
- $(MAKEREC) partialclean
-
-flexlink.opt:
- cd flexdll && \
- mv flexlink.exe flexlink && \
- $(MAKECMD) OCAML_FLEXLINK="../boot/ocamlrun ./flexlink" MSVC_DETECT=0 \
- TOOLCHAIN=$(TOOLCHAIN) TOOLPREF=$(TOOLPREF) \
- OCAMLOPT="../ocamlopt.opt -I ../stdlib" flexlink.exe && \
- mv flexlink.exe flexlink.opt && \
- mv flexlink flexlink.exe
-
-# Recompile the system using the bootstrap compiler
-all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml \
- otherlibraries $(WITH_DEBUGGER) $(WITH_OCAMLDOC)
-
-# The compilation of ocaml will fail if the runtime has changed.
-# Never mind, just do make bootstrap to reach fixpoint again.
-
-# Compile everything the first time
-world: coldstart all
-
-# Core bootstrapping cycle
-coreboot:
-# Save the original bootstrap compiler
- $(MAKEREC) backup
-# Promote the new compiler but keep the old runtime
-# This compiler runs on boot/ocamlrun and produces bytecode for
-# byterun/ocamlrun
- $(MAKEREC) promote-cross
-# Rebuild ocamlc and ocamllex (run on byterun/ocamlrun)
- $(MAKEREC) partialclean
- $(MAKEREC) ocamlc ocamllex ocamltools
-# Rebuild the library (using byterun/ocamlrun ./ocamlc)
- $(MAKEREC) library-cross
-# Promote the new compiler and the new runtime
- $(MAKEREC) promote
-# Rebuild the core system
- $(MAKEREC) partialclean
- $(MAKEREC) core
-# Check if fixpoint reached
- $(MAKEREC) compare
-
-# Do a complete bootstrapping cycle
-bootstrap:
- $(MAKEREC) coreboot
- $(MAKEREC) all
- $(MAKEREC) compare
-
-LIBFILES=stdlib.cma std_exit.cmo *.cmi camlheader
-
-# Start up the system from the distribution compiler
-coldstart:
- cd byterun ; $(MAKEREC) $(BOOT_FLEXLINK_CMD) all
- 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 -use-prims ../byterun/primitives"\
- all
- cd stdlib ; cp $(LIBFILES) ../boot
-
-# Build the core system: the minimum needed to make depend and bootstrap
-core: runtime ocamlc ocamllex ocamlyacc ocamltools library
-
-# Save the current bootstrap compiler
-MAXSAVED=boot/Saved/Saved.prev/Saved.prev/Saved.prev/Saved.prev/Saved.prev
-backup:
- mkdir -p boot/Saved
- if test -d $(MAXSAVED); then rm -r $(MAXSAVED); fi
- mv boot/Saved boot/Saved.prev
- mkdir boot/Saved
- mv boot/Saved.prev boot/Saved/Saved.prev
- cp boot/ocamlrun.exe boot/Saved/ocamlrun.exe
- cd boot ; mv ocamlc ocamllex ocamldep ocamlyacc.exe Saved
- cd boot ; cp $(LIBFILES) Saved
-
-# Promote the newly compiled system to the rank of cross compiler
-# (Runs on the old runtime, produces code for the new runtime)
-promote-cross:
- $(CAMLRUN) tools/stripdebug ocamlc boot/ocamlc
- $(CAMLRUN) tools/stripdebug lex/ocamllex boot/ocamllex
- cp yacc/ocamlyacc.exe boot/ocamlyacc.exe
- $(CAMLRUN) tools/stripdebug tools/ocamldep boot/ocamldep
- cd stdlib ; cp $(LIBFILES) ../boot
-
-# Promote the newly compiled system to the rank of bootstrap compiler
-# (Runs on the new runtime, produces code for the new runtime)
-promote: promote-cross
- cp byterun/ocamlrun.exe boot/ocamlrun.exe
-
-# Restore the saved bootstrap compiler if a problem arises
-restore:
- cd boot/Saved ; mv * ..
- rmdir boot/Saved
- mv boot/Saved.prev boot/Saved
-
-# Check if fixpoint reached
-compare:
- @if $(CAMLRUN) tools/cmpbyt boot/ocamlc ocamlc \
- && $(CAMLRUN) tools/cmpbyt boot/ocamllex lex/ocamllex \
- && $(CAMLRUN) tools/cmpbyt boot/ocamldep tools/ocamldep; \
- then echo "Fixpoint reached, bootstrap succeeded."; \
- else echo "Fixpoint not reached, try one more bootstrapping cycle."; \
- fi
-
-# Remove old bootstrap compilers
-cleanboot:
- rm -rf boot/Saved/Saved.prev/*
-
-# Compile the native-code compiler
-opt-core:
- $(MAKEREC) runtimeopt
- $(MAKEREC) ocamlopt
- $(MAKEREC) libraryopt
-
-opt:
- $(MAKEREC) opt-core
- $(MAKEREC) otherlibrariesopt ocamltoolsopt
-
-# Native-code versions of the tools
-# If the submodule is initialised, then opt.opt will build a native flexlink
-opt.opt: core opt-core ocamlc.opt all ocamlopt.opt ocamllex.opt \
- ocamltoolsopt ocamltoolsopt.opt otherlibrariesopt $(OCAMLDOC_OPT) \
- $(if $(wildcard flexdll/Makefile),flexlink.opt)
-
-# Complete build using fast compilers
-world.opt: coldstart opt.opt
-
-# Installation
-
-COMPLIBDIR=$(LIBDIR)/compiler-libs
-
-INSTALL_BINDIR=$(DESTDIR)$(BINDIR)
-INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
-INSTALL_COMPLIBDIR=$(DESTDIR)$(COMPLIBDIR)
-INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR)
-INSTALL_MANDIR=$(DESTDIR)$(MANDIR)
-INSTALL_DISTRIB=$(DESTDIR)$(PREFIX)
-
-install: installbyt installopt
-
-installbyt:
- mkdir -p "$(INSTALL_BINDIR)"
- mkdir -p "$(INSTALL_LIBDIR)"
- mkdir -p "$(INSTALL_STUBLIBDIR)"
- mkdir -p "$(INSTALL_COMPLIBDIR)"
- cp VERSION "$(INSTALL_LIBDIR)/"
- 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 \
- bytecomp/*.cmi bytecomp/*.cmt bytecomp/*.cmti \
- driver/*.cmi driver/*.cmt driver/*.cmti \
- toplevel/*.cmi toplevel/*.cmt toplevel/*.cmti "$(INSTALL_COMPLIBDIR)"
- cp compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \
- compilerlibs/ocamltoplevel.cma $(BYTESTART) $(TOPLEVELSTART) \
- "$(INSTALL_COMPLIBDIR)"
- cp expunge "$(INSTALL_LIBDIR)/expunge.exe"
- cp toplevel/topdirs.cmi "$(INSTALL_LIBDIR)"
- cd tools ; $(MAKEREC) install
- for i in $(OTHERLIBRARIES); do \
- $(MAKEREC) -C otherlibs/$$i install || exit $$?; \
- done
- if test -n "$(WITH_OCAMLDOC)"; then \
- (cd ocamldoc; $(MAKEREC) install); \
- fi
- if test -n "$(WITH_DEBUGGER)"; then \
- (cd debugger; $(MAKEREC) install); \
- fi
- if test -n "$(FLEXDLL_SUBMODULE_PRESENT)"; then \
- $(MAKEREC) install-flexdll; \
- fi
- cp config/Makefile "$(INSTALL_LIBDIR)/Makefile.config"
- 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
-# (GNU make doesn't have ifeq as a function, hence slightly convoluted use of
-# filter-out)
- cp flexdll/flexlink.exe \
- $(if $(filter-out mingw,$(TOOLCHAIN)),\
- flexdll/default$(filter-out _i386,_$(ARCH)).manifest) \
- $(INSTALL_BINDIR)/
- cp flexdll/flexdll_*.$(O) $(INSTALL_LIBDIR)
-
-# Installation of the native-code compiler
-installopt:
- cd asmrun && $(MAKEREC) install
- cp ocamlopt "$(INSTALL_BINDIR)/ocamlopt.exe"
- cp ocamlopt "$(INSTALL_BINDIR)/ocamlopt.byte.exe"
- cd stdlib && $(MAKEREC) installopt
- cp middle_end/*.cmi middle_end/*.cmt middle_end/*.cmti \
- "$(INSTALL_COMPLIBDIR)"
- cp middle_end/base_types/*.cmi middle_end/base_types/*.cmt \
- middle_end/base_types/*.cmti "$(INSTALL_COMPLIBDIR)"
- cp asmcomp/*.cmi asmcomp/*.cmt asmcomp/*.cmti "$(INSTALL_COMPLIBDIR)"
- cp compilerlibs/ocamloptcomp.cma $(OPTSTART) "$(INSTALL_COMPLIBDIR)"
- if test -n "$(WITH_OCAMLDOC)"; then \
- (cd ocamldoc && $(MAKEREC) installopt); \
- fi
- for i in $(OTHERLIBRARIES); do \
- $(MAKEREC) -C otherlibs/$$i installopt || exit $$?; \
- done
- if test -f ocamlopt.opt ; then $(MAKEREC) installoptopt; fi
- cd tools; $(MAKEREC) installopt
- if test -f ocamlopt.opt -a -f flexdll/flexlink.opt ; then \
- cp -f flexdll/flexlink.opt $(INSTALL_BINDIR)/flexlink.exe ; \
- fi
-
-installoptopt:
- cp ocamlc.opt "$(INSTALL_BINDIR)/ocamlc.opt$(EXE)"
- 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) \
- compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.$(A) \
- compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.$(A) \
- $(BYTESTART:.cmo=.cmx) $(BYTESTART:.cmo=.$(O)) \
- $(OPTSTART:.cmo=.cmx) $(OPTSTART:.cmo=.$(O)) \
- "$(INSTALL_COMPLIBDIR)"
-
-# Run all tests
-
-tests: opt.opt
- cd testsuite && $(MAKE) clean && $(MAKE) all
-
-# The clean target
-
-clean:: partialclean
-
-# The compiler
-
-compilerlibs/ocamlcommon.cma: $(COMMON)
- $(CAMLC) -a -o $@ $(COMMON)
-partialclean::
- rm -f compilerlibs/ocamlcommon.cma
-
-# The bytecode compiler
-
-compilerlibs/ocamlbytecomp.cma: $(BYTECOMP)
- $(CAMLC) -a -o $@ $(BYTECOMP)
-partialclean::
- rm -f compilerlibs/ocamlbytecomp.cma
-
-ocamlc: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART)
- $(CAMLC) $(LINKFLAGS) -compat-32 -o ocamlc \
- compilerlibs/ocamlcommon.cma \
- compilerlibs/ocamlbytecomp.cma $(BYTESTART)
-
-partialclean::
- rm -f ocamlc
-
-# The native-code compiler
-
-compilerlibs/ocamloptcomp.cma: $(MIDDLE_END) $(ASMCOMP)
- $(CAMLC) -a -o $@ $(MIDDLE_END) $(ASMCOMP)
-partialclean::
- rm -f compilerlibs/ocamloptcomp.cma
-
-ocamlopt: compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma \
- compilerlibs/ocamlbytecomp.cma $(OPTSTART)
- $(CAMLC) $(LINKFLAGS) -o ocamlopt \
- compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma \
- compilerlibs/ocamlbytecomp.cma $(OPTSTART)
-
-partialclean::
- rm -f ocamlopt
-
-# The toplevel
-
-compilerlibs/ocamltoplevel.cma: $(TOPLEVEL)
- $(CAMLC) -a -o $@ $(TOPLEVEL)
-partialclean::
- rm -f compilerlibs/ocamltoplevel.cma
-
-ocaml: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \
- compilerlibs/ocamltoplevel.cma $(TOPLEVELSTART) expunge
- $(CAMLC) $(LINKFLAGS) -linkall -o ocaml.tmp \
- compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \
- compilerlibs/ocamltoplevel.cma $(TOPLEVELSTART)
- - $(CAMLRUN) ./expunge ocaml.tmp ocaml $(PERVASIVES)
- rm -f ocaml.tmp
-
-partialclean::
- rm -f ocaml
-
-# The native toplevel
-
-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
-
-otherlibs/dynlink/dynlink.cmxa: otherlibs/dynlink/natdynlink.ml
- cd otherlibs/dynlink && $(MAKEREC) allopt
-
-
-# The configuration file
-
-utils/config.ml: utils/config.mlp config/Makefile
- @rm -f utils/config.ml
- sed -e "s|%%LIBDIR%%|$(LIBDIR)|" \
- -e "s|%%BYTERUN%%|ocamlrun|" \
- -e 's|%%CCOMPTYPE%%|$(CCOMPTYPE)|' \
- -e "s|%%BYTECC%%|$(BYTECC) $(BYTECCCOMPOPTS)|" \
- -e "s|%%NATIVECC%%|$(NATIVECC) $(NATIVECCCOMPOPTS)|" \
- -e "s|%%PARTIALLD%%|$(PARTIALLD)|" \
- -e "s|%%PACKLD%%|$(PACKLD)|" \
- -e "s|%%BYTECCLIBS%%|$(BYTECCLIBS)|" \
- -e "s|%%NATIVECCLIBS%%|$(NATIVECCLIBS)|" \
- -e 's|%%RANLIBCMD%%|$(RANLIBCMD)|' \
- -e 's|%%ARCMD%%|$(ARCMD)|' \
- -e 's|%%BINUTILS_NM%%|$(BINUTILS_NM)|' \
- -e 's|%%BINUTILS_OBJCOPY%%|$(BINUTILS_OBJCOPY)|' \
- -e "s|%%ARCH%%|$(ARCH)|" \
- -e "s|%%MODEL%%|$(MODEL)|" \
- -e "s|%%SYSTEM%%|$(SYSTEM)|" \
- -e "s|%%EXT_OBJ%%|.$(O)|" \
- -e "s|%%EXT_ASM%%|.$(S)|" \
- -e "s|%%EXT_LIB%%|.$(A)|" \
- -e "s|%%EXT_DLL%%|.dll|" \
- -e "s|%%SYSTHREAD_SUPPORT%%|true|" \
- -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)|' \
- -e 's|%%CC_PROFILE%%||' \
- -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
-
-partialclean::
- rm -f utils/config.ml
-
-beforedepend:: utils/config.ml
-
-# The parser
-
-parsing/parser.mli parsing/parser.ml: parsing/parser.mly
- $(CAMLYACC) $(YACCFLAGS) parsing/parser.mly
-
-partialclean::
- rm -f parsing/parser.mli parsing/parser.ml parsing/parser.output
-
-beforedepend:: parsing/parser.mli parsing/parser.ml
-
-# The lexer
-
-parsing/lexer.ml: parsing/lexer.mll
- $(CAMLLEX) parsing/lexer.mll
-
-partialclean::
- rm -f parsing/lexer.ml
-
-beforedepend:: parsing/lexer.ml
-
-# Shared parts of the system compiled with the native-code compiler
-
-compilerlibs/ocamlcommon.cmxa: $(COMMON:.cmo=.cmx)
- $(CAMLOPT) -a -o $@ $(COMMON:.cmo=.cmx)
-partialclean::
- rm -f compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.$(A)
-
-# The bytecode compiler compiled with the native-code compiler
-
-compilerlibs/ocamlbytecomp.cmxa: $(BYTECOMP:.cmo=.cmx)
- $(CAMLOPT) -a -o $@ $(BYTECOMP:.cmo=.cmx)
-partialclean::
- rm -f compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.$(A)
-
-ocamlc.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \
- $(BYTESTART:.cmo=.cmx)
- $(CAMLOPT) $(LINKFLAGS) -ccopt "$(BYTECCLINKOPTS)" -o ocamlc.opt \
- compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \
- $(BYTESTART:.cmo=.cmx) -cclib "$(BYTECCLIBS)"
-
-partialclean::
- rm -f ocamlc.opt
-
-# The native-code compiler compiled with itself
-
-compilerlibs/ocamloptcomp.cmxa: $(MIDDLE_END:.cmo=.cmx) $(ASMCOMP:.cmo=.cmx)
- $(CAMLOPT) -a -o $@ $(MIDDLE_END:.cmo=.cmx) $(ASMCOMP:.cmo=.cmx)
-partialclean::
- rm -f compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.$(A)
-
-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::
- rm -f ocamlopt.opt
-
-$(COMMON:.cmo=.cmx) $(BYTECOMP:.cmo=.cmx) $(MIDDLE_END:.cmo=.cmx) \
-$(ASMCOMP:.cmo=.cmx): ocamlopt
-
-# The numeric opcodes
-
-bytecomp/opcodes.ml: byterun/caml/instruct.h
- sed -n -e "/^enum/p" -e "s|,||g" -e "/^ /p" byterun/caml/instruct.h | \
- gawk -f tools/make-opcodes > bytecomp/opcodes.ml
-
-partialclean::
- rm -f bytecomp/opcodes.ml
-
-beforedepend:: bytecomp/opcodes.ml
-
-# The predefined exceptions and primitives
-
-byterun/primitives:
- cd byterun ; $(MAKEREC) primitives
-
-bytecomp/runtimedef.ml: byterun/primitives byterun/caml/fail.h
- (echo 'let builtin_exceptions = [|'; \
- sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$$| \1;|p' \
- byterun/caml/fail.h; \
- echo '|]'; \
- echo 'let builtin_primitives = [|'; \
- sed -e 's/.*/ "&";/' byterun/primitives; \
- echo '|]') > bytecomp/runtimedef.ml
-
-partialclean::
- rm -f bytecomp/runtimedef.ml
-
-beforedepend:: bytecomp/runtimedef.ml
-
-# Choose the right machine-dependent files
-
-asmcomp/arch.ml: asmcomp/$(ARCH)/arch.ml
- cp asmcomp/$(ARCH)/arch.ml asmcomp/arch.ml
-
-partialclean::
- rm -f asmcomp/arch.ml
-
-beforedepend:: asmcomp/arch.ml
-
-asmcomp/proc.ml: asmcomp/$(ARCH)/proc.ml
- cp asmcomp/$(ARCH)/proc.ml asmcomp/proc.ml
-
-partialclean::
- rm -f asmcomp/proc.ml
-
-beforedepend:: asmcomp/proc.ml
-
-asmcomp/selection.ml: asmcomp/$(ARCH)/selection.ml
- cp asmcomp/$(ARCH)/selection.ml asmcomp/selection.ml
-
-partialclean::
- rm -f asmcomp/selection.ml
-
-beforedepend:: asmcomp/selection.ml
-
-asmcomp/CSE.ml: asmcomp/$(ARCH)/CSE.ml
- cp asmcomp/$(ARCH)/CSE.ml asmcomp/CSE.ml
-
-partialclean::
- rm -f asmcomp/CSE.ml
-
-beforedepend:: asmcomp/CSE.ml
-
-asmcomp/reload.ml: asmcomp/$(ARCH)/reload.ml
- cp asmcomp/$(ARCH)/reload.ml asmcomp/reload.ml
-
-partialclean::
- rm -f asmcomp/reload.ml
-
-beforedepend:: asmcomp/reload.ml
-
-asmcomp/scheduling.ml: asmcomp/$(ARCH)/scheduling.ml
- cp asmcomp/$(ARCH)/scheduling.ml asmcomp/scheduling.ml
-
-partialclean::
- rm -f asmcomp/scheduling.ml
-
-beforedepend:: asmcomp/scheduling.ml
-
-# Preprocess the code emitters
-
-asmcomp/emit.ml: asmcomp/$(ARCH)/emit.mlp tools/cvt_emit
- $(CAMLRUN) tools/cvt_emit < asmcomp/$(ARCH)/emit.mlp > asmcomp/emit.ml
-
-partialclean::
- rm -f asmcomp/emit.ml
-
-beforedepend:: asmcomp/emit.ml
-
-tools/cvt_emit: tools/cvt_emit.mll
- cd tools ; $(MAKEREC) cvt_emit
-
-# The "expunge" utility
-
-expunge: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \
- toplevel/expunge.cmo
- $(CAMLC) $(LINKFLAGS) -o expunge compilerlibs/ocamlcommon.cma \
- compilerlibs/ocamlbytecomp.cma toplevel/expunge.cmo
-
-partialclean::
- rm -f expunge
-
-# The runtime system for the bytecode compiler
-
-runtime: makeruntime stdlib/libcamlrun.$(A)
-
-makeruntime:
- cd byterun ; $(MAKEREC) $(BOOT_FLEXLINK_CMD) all
-stdlib/libcamlrun.$(A): byterun/libcamlrun.$(A)
- cp byterun/libcamlrun.$(A) stdlib/libcamlrun.$(A)
-clean::
- cd byterun ; $(MAKEREC) clean
- rm -f stdlib/libcamlrun.$(A)
-alldepend::
- cd byterun ; $(MAKEREC) depend
-
-# The runtime system for the native-code compiler
-
-runtimeopt: makeruntimeopt stdlib/libasmrun.$(A)
-
-makeruntimeopt:
- cd asmrun ; $(MAKEREC) $(BOOT_FLEXLINK_CMD) all
-stdlib/libasmrun.$(A): asmrun/libasmrun.$(A)
- cp asmrun/libasmrun.$(A) stdlib/libasmrun.$(A)
-clean::
- cd asmrun ; $(MAKEREC) clean
- rm -f stdlib/libasmrun.$(A)
-alldepend::
- cd asmrun ; $(MAKEREC) depend
-
-# The library
-
-library:
- cd stdlib && $(MAKEREC) $(BOOT_FLEXLINK_CMD) all
-library-cross:
- cd stdlib \
- && $(MAKEREC) $(BOOT_FLEXLINK_CMD) CAMLRUN=../byterun/ocamlrun all
-libraryopt:
- cd stdlib && $(MAKEREC) $(BOOT_FLEXLINK_CMD) allopt
-partialclean::
- cd stdlib && $(MAKEREC) clean
-alldepend::
- cd stdlib && $(MAKEREC) depend
-
-# The lexer and parser generators
-
-ocamllex:
- cd lex ; $(MAKEREC) all
-ocamllex.opt:
- cd lex ; $(MAKEREC) allopt
-partialclean::
- cd lex ; $(MAKEREC) clean
-alldepend::
- cd lex ; $(MAKEREC) depend
-
-ocamlyacc:
- cd yacc ; $(MAKEREC) $(BOOT_FLEXLINK_CMD) all
-clean::
- cd yacc ; $(MAKEREC) clean
-
-# OCamldoc
-
-ocamldoc:
- cd ocamldoc ; $(MAKEREC) all
-ocamldoc.opt:
- cd ocamldoc ; $(MAKEREC) opt.opt
-partialclean::
- cd ocamldoc ; $(MAKEREC) clean
-alldepend::
- cd ocamldoc ; $(MAKEREC) depend
-
-# The extra libraries
-
-otherlibraries:
- for i in $(OTHERLIBRARIES); do \
- $(MAKEREC) -C otherlibs/$$i all || exit $$?; \
- done
-otherlibrariesopt:
- for i in $(OTHERLIBRARIES); \
- do $(MAKEREC) -C otherlibs/$$i allopt || exit $$?; \
- done
-partialclean::
- for i in $(OTHERLIBRARIES); \
- do $(MAKEREC) -C otherlibs/$$i partialclean || exit $$?; \
- done
-clean::
- for i in $(OTHERLIBRARIES); do \
- $(MAKEREC) -C otherlibs/$$i clean || exit $$?; \
- done
-alldepend::
- for i in $(OTHERLIBRARIES); do \
- $(MAKEREC) -C otherlibs/$$i depend || exit $$?; \
- done
-
-# The replay debugger
-
-ocamldebugger: ocamlc ocamlyacc ocamllex
- cd debugger; $(MAKEREC) all
-partialclean::
- cd debugger; $(MAKEREC) clean
-alldepend::
- cd debugger; $(MAKEREC) depend
-
-# Make clean in the test suite
-
-clean::
- cd testsuite; $(MAKE) clean
-
-# Default rules
-
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-
-.ml.cmo:
- $(CAMLC) $(COMPFLAGS) -c $<
-
-.mli.cmi:
- $(CAMLC) $(COMPFLAGS) -c $<
-
-.ml.cmx:
- $(CAMLOPT) $(COMPFLAGS) -c $<
-
-partialclean::
- rm -f utils/*.cm* utils/*.$(O) utils/*.$(S)
- rm -f parsing/*.cm* parsing/*.$(O) parsing/*.$(S)
- rm -f typing/*.cm* typing/*.$(O) typing/*.$(S)
- rm -f bytecomp/*.cm* bytecomp/*.$(O) bytecomp/*.$(S)
- rm -f asmcomp/*.cm* asmcomp/*.$(O) asmcomp/*.$(S)
- rm -f middle_end/*.cm* middle_end/*.$(O) middle_end/*.$(S)
- rm -f middle_end/base_types/*.cm* middle_end/base_types/*.$(O) \
- middle_end/base_types/*.$(S)
- rm -f driver/*.cm* driver/*.$(O) driver/*.$(S)
- rm -f toplevel/*.cm* toplevel/*.$(O) toplevel/*.$(S)
- rm -f tools/*.cm* tools/*.$(O) tools/*.$(S)
-
-depend: beforedepend
- (for d in utils parsing typing bytecomp asmcomp middle_end \
- middle_end/base_types driver toplevel; \
- 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 \
- 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
- rm -f tools/*.bak
- rm -f ocaml ocamlc
- rm -f testsuite/_log
-
-.PHONY: all backup bootstrap checkstack clean
-.PHONY: partialclean beforedepend alldepend cleanboot coldstart
-.PHONY: compare core coreall
-.PHONY: coreboot defaultentry depend distclean install installopt
-.PHONY: library library-cross libraryopt
-.PHONY: ocamldebugger ocamldoc
-.PHONY: ocamldoc.opt ocamllex ocamllex.opt ocamltools ocamltoolsopt
-.PHONY: ocamltoolsopt.opt ocamlyacc opt-core opt opt.opt otherlibraries
-.PHONY: otherlibrariesopt promote promote-cross
-.PHONY: restore runtime runtimeopt makeruntimeopt world world.opt
-.PHONY: flexdll flexlink.opt flexdll-common-err flexdll-repo
-
-include .depend
+include Makefile
+++ /dev/null
-#**************************************************************************
-#* *
-#* 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. *
-#* *
-#**************************************************************************
-
-# For users who don't read the INSTALL file
-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 -use-prims byterun/primitives
-CAMLOPT=$(CAMLRUN) ./ocamlopt -g -nostdlib -I stdlib -I otherlibs/dynlink
-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 --strict
-CAMLLEX=$(CAMLRUN) boot/ocamllex
-CAMLDEP=$(CAMLRUN) tools/ocamldep
-DEPFLAGS=$(INCLUDES)
-
-OCAMLBUILDBYTE=$(WITH_OCAMLBUILD:=.byte)
-OCAMLBUILDNATIVE=$(WITH_OCAMLBUILD:=.native)
-
-OCAMLDOC_OPT=$(WITH_OCAMLDOC:=.opt)
-
-INCLUDES=-I utils -I parsing -I typing -I bytecomp -I middle_end \
- -I middle_end/base_types -I asmcomp -I driver -I toplevel
-
-UTILS=utils/config.cmo utils/misc.cmo \
- utils/identifiable.cmo utils/numbers.cmo utils/arg_helper.cmo \
- utils/clflags.cmo utils/tbl.cmo utils/timings.cmo \
- utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \
- utils/consistbl.cmo \
- utils/strongly_connected_components.cmo
-
-PARSING=parsing/location.cmo parsing/longident.cmo \
- parsing/docstrings.cmo parsing/ast_helper.cmo \
- parsing/syntaxerr.cmo parsing/parser.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/depend.cmo
-
-TYPING=typing/ident.cmo typing/path.cmo \
- typing/primitive.cmo typing/types.cmo \
- typing/btype.cmo typing/oprint.cmo \
- typing/subst.cmo typing/predef.cmo \
- typing/datarepr.cmo typing/cmi_format.cmo typing/env.cmo \
- typing/typedtree.cmo typing/printtyped.cmo typing/ctype.cmo \
- typing/printtyp.cmo typing/includeclass.cmo \
- typing/mtype.cmo typing/envaux.cmo typing/includecore.cmo \
- typing/typedtreeIter.cmo typing/typedtreeMap.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/typedecl.cmo typing/typecore.cmo \
- typing/typeclass.cmo \
- typing/typemod.cmo
-
-COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \
- bytecomp/typeopt.cmo bytecomp/switch.cmo bytecomp/matching.cmo \
- bytecomp/translobj.cmo bytecomp/translattribute.cmo \
- bytecomp/translcore.cmo \
- bytecomp/translclass.cmo bytecomp/translmod.cmo \
- bytecomp/simplif.cmo bytecomp/runtimedef.cmo \
- driver/pparse.cmo driver/main_args.cmo \
- driver/compenv.cmo driver/compmisc.cmo
-
-COMMON=$(UTILS) $(PARSING) $(TYPING) $(COMP)
-
-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=\
- asmcomp/x86_proc.cmo \
- asmcomp/x86_dsl.cmo \
- asmcomp/x86_gas.cmo \
- asmcomp/x86_masm.cmo
-
-ARCH_SPECIFIC_ASMCOMP=
-ifeq ($(ARCH),i386)
-ARCH_SPECIFIC_ASMCOMP=$(INTEL_ASM)
-endif
-ifeq ($(ARCH),amd64)
-ARCH_SPECIFIC_ASMCOMP=$(INTEL_ASM)
-endif
-
-ASMCOMP=\
- $(ARCH_SPECIFIC_ASMCOMP) \
- asmcomp/arch.cmo \
- asmcomp/cmm.cmo asmcomp/printcmm.cmo \
- asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \
- asmcomp/clambda.cmo asmcomp/printclambda.cmo \
- asmcomp/export_info.cmo \
- asmcomp/export_info_for_pack.cmo \
- asmcomp/compilenv.cmo \
- asmcomp/closure.cmo \
- asmcomp/build_export_info.cmo \
- asmcomp/closure_offsets.cmo \
- asmcomp/flambda_to_clambda.cmo \
- asmcomp/import_approx.cmo \
- asmcomp/un_anf.cmo \
- asmcomp/strmatch.cmo asmcomp/cmmgen.cmo \
- asmcomp/printmach.cmo asmcomp/selectgen.cmo \
- asmcomp/spacetime_profiling.cmo asmcomp/selection.cmo \
- asmcomp/comballoc.cmo \
- asmcomp/CSEgen.cmo asmcomp/CSE.cmo \
- asmcomp/liveness.cmo \
- asmcomp/spill.cmo asmcomp/split.cmo \
- asmcomp/interf.cmo asmcomp/coloring.cmo \
- asmcomp/reloadgen.cmo asmcomp/reload.cmo \
- asmcomp/deadcode.cmo \
- asmcomp/printlinear.cmo asmcomp/linearize.cmo \
- asmcomp/schedgen.cmo asmcomp/scheduling.cmo \
- asmcomp/branch_relaxation_intf.cmo \
- asmcomp/branch_relaxation.cmo \
- asmcomp/emitaux.cmo asmcomp/emit.cmo asmcomp/asmgen.cmo \
- asmcomp/asmlink.cmo asmcomp/asmlibrarian.cmo asmcomp/asmpackager.cmo \
- 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 \
- middle_end/base_types/variable.cmo \
- middle_end/base_types/mutable_variable.cmo \
- middle_end/base_types/id_types.cmo \
- middle_end/base_types/set_of_closures_id.cmo \
- middle_end/base_types/set_of_closures_origin.cmo \
- middle_end/base_types/closure_element.cmo \
- middle_end/base_types/closure_id.cmo \
- middle_end/base_types/var_within_closure.cmo \
- middle_end/base_types/static_exception.cmo \
- middle_end/base_types/export_id.cmo \
- middle_end/base_types/symbol.cmo \
- middle_end/pass_wrapper.cmo \
- middle_end/semantics_of_primitives.cmo \
- middle_end/allocated_const.cmo \
- middle_end/projection.cmo \
- middle_end/flambda.cmo \
- middle_end/flambda_iterators.cmo \
- middle_end/flambda_utils.cmo \
- middle_end/inlining_cost.cmo \
- middle_end/effect_analysis.cmo \
- middle_end/freshening.cmo \
- middle_end/simple_value_approx.cmo \
- middle_end/lift_code.cmo \
- middle_end/closure_conversion_aux.cmo \
- middle_end/closure_conversion.cmo \
- middle_end/initialize_symbol_to_let_symbol.cmo \
- middle_end/lift_let_to_initialize_symbol.cmo \
- middle_end/find_recursive_functions.cmo \
- middle_end/invariant_params.cmo \
- middle_end/inconstant_idents.cmo \
- middle_end/alias_analysis.cmo \
- middle_end/lift_constants.cmo \
- middle_end/share_constants.cmo \
- middle_end/simplify_common.cmo \
- middle_end/remove_unused_arguments.cmo \
- middle_end/remove_unused_closure_vars.cmo \
- middle_end/remove_unused_program_constructs.cmo \
- middle_end/simplify_boxed_integer_ops.cmo \
- middle_end/simplify_primitives.cmo \
- middle_end/inlining_stats_types.cmo \
- middle_end/inlining_stats.cmo \
- middle_end/inline_and_simplify_aux.cmo \
- middle_end/remove_free_vars_equal_to_args.cmo \
- middle_end/extract_projections.cmo \
- middle_end/augment_specialised_args.cmo \
- middle_end/unbox_free_vars_of_closures.cmo \
- middle_end/unbox_specialised_args.cmo \
- middle_end/unbox_closures.cmo \
- middle_end/inlining_transforms.cmo \
- middle_end/inlining_decision.cmo \
- middle_end/inline_and_simplify.cmo \
- middle_end/ref_to_variables.cmo \
- middle_end/flambda_invariants.cmo \
- middle_end/middle_end.cmo
-
-TOPLEVEL=toplevel/genprintval.cmo toplevel/toploop.cmo \
- toplevel/trace.cmo toplevel/topdirs.cmo toplevel/topmain.cmo
-
-OPTTOPLEVEL=toplevel/genprintval.cmo toplevel/opttoploop.cmo \
- toplevel/opttopdirs.cmo toplevel/opttopmain.cmo
-BYTESTART=driver/main.cmo
-
-OPTSTART=driver/optmain.cmo
-
-TOPLEVELSTART=toplevel/topstart.cmo
-
-OPTTOPLEVELSTART=toplevel/opttopstart.cmo
-
-PERVASIVES=$(STDLIB_MODULES) outcometree topdirs toploop
-
-
-# The middle end (whose .cma library is currently only used for linking
-# the "ocamlobjinfo" program, since we cannot depend on the whole native code
-# compiler for "make world" and the list of dependencies for
-# asmcomp/export_info.cmo is long).
-
-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 compilerlibs/ocamlmiddleend.cmxa \
- compilerlibs/ocamlmiddleend.$(A)
-
-
-# Tools
-
-ocamltools: ocamlc ocamlyacc ocamllex asmcomp/cmx_format.cmi \
- asmcomp/printclambda.cmo compilerlibs/ocamlmiddleend.cma \
- asmcomp/export_info.cmo
- +cd tools ; $(MAKEREC) all
-
-ocamltoolsopt: ocamlopt
- +cd tools; $(MAKEREC) 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
-
-alldepend::
- +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
additional reserved keywords that have forced some renaming of standard
library functions.
-== 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:: 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
All files marked "Copyright INRIA" in this distribution are copyright 1996,
== Installation
-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[].
+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
You can also contact the implementors directly at mailto:caml@inria.fr[].
-For information on contributing to OCaml, see the file CONTRIBUTING.md.
+For information on contributing to OCaml, see link:HACKING.adoc[] and
+link:CONTRIBUTING.md[].
|=====
[[tb1]]
-(*):: Cygwin-generated `.exe` files refer to a DLL that is distributed under the
-GPL. Thus, these `.exe` files can only be distributed under a license that is
-compatible with the GPL. Executables generated by Microsoft Visual C++ or
-Mingw-w64 have no such restrictions.
+(*):: Executables generated by the native GCC package in Cygwin are linked with
+the Cygwin DLL and require this to be distributed with your programs.
+Executables generated by Microsoft Visual C++ or the Mingw-w64 compilers (even
+when run in Cygwin as `i686-w64-mingw32-gcc` or `x86_64-w64-mingw32-gcc`) are
+not linked against this DLL. Prior to Cygwin 2.5.2 (the Cygwin version can be
+obtained with `uname -r`) the Cygwin DLL is distributed under the GPL, requiring
+any programs linked with it to be distributed under a compatible licence. Since
+version 2.5.2, the Cygwin DLL is distributed under the LGPLv3 with a static
+linking exception meaning that, like executables generated by Microsoft Visual
+C++ or the Mingw-w64 compilers, generated executables may be distributed under
+terms of your choosing.
[[tb2]]
(**):: The debugger is supported but the "replay" functions are not enabled.
FlexDLL and OCaml are given <<seflexdll,later in this document>>. Unless you
bootstrap FlexDLL, you will need to ensure that the directory to which you
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.
+use Visual Studio 2015 or Visual Studio 2017, 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.
| Visual Studio 2012 | 17.00.x.x | 32/64-bit |
| Visual Studio 2013 | 18.00.x.x | 32/64-bit |
| Visual Studio 2015 | 19.00.x.x | 32/64-bit |
+| Visual Studio 2017 | 19.10.x.x | 32/64-bit |
|=====
[[vs1]]
for 64-bit. For Visual Studio 2005-2013, you need to use one of the shortcuts in
the "Visual Studio Tools" program group under the main program group for the
-version of Visual Studio you installed. For Visual Studio 2015, you need to use
-the shortcuts in the "Windows Desktop Command Prompts" group under the
-"Visual Studio Tools" group.
+version of Visual Studio you installed. For Visual Studio 2015 and 2017, you
+need to use the shortcuts in the "Windows Desktop Command Prompts" (2015) or
+"VC" (2017) group under the "Visual Studio Tools" group.
Unlike `SetEnv` for the Windows SDK, the architecture is selected by using a
different shortcut, rather than by running a command.
For Visual Studio 2012 and 2013, both x86 and x64 Command Prompt shortcuts
indicate if they are the "Native Tools" or "Cross Tools" versions. Visual Studio
-2015 makes the shortcuts even clearer by including the full name of the
+2015 and 2017 make the shortcuts even clearer by including the full name of the
architecture.
You cannot at present use a cross-compiler to compile 64-bit OCaml on 32-bit
eval $(tools/msvs-promote-path)
-If you forget to do this, `make -f Makefile.nt world` will fail relatively
+If you forget to do this, `make world` will fail relatively
quickly as it will be unable to link `ocamlrun`.
Now run:
this file. Normally, the only variable that needs to be changed is `PREFIX`,
which indicates where to install everything.
-Finally, use `make -f Makefile.nt` to build the system, e.g.
+Finally, use `make` to build the system, e.g.
- make -f Makefile.nt world bootstrap opt opt.opt install
+ make world bootstrap opt opt.opt install
After installing, it is not necessary to keep the Cygwin installation (although
you may require it to build additional third party libraries and tools). You
this file. Normally, the only variable that needs to be changed is `PREFIX`,
which indicates where to install everything.
-Finally, use `make -f Makefile.nt` to build the system, e.g.
+Finally, use `make` to build the system, e.g.
- make -f Makefile.nt world bootstrap opt opt.opt install
+ make world bootstrap opt opt.opt install
After installing, you will need to ensure that `ocamlopt` (or `ocamlc -custom`)
can access the C compiler. You can do this either by using OCaml from Cygwin's
OCaml is then compiled as normal for the port you require, except that before
compiling `world`, you must compile `flexdll`, i.e.:
- make -f Makefile.nt flexdll world [bootstrap] opt opt.opt install
+ make flexdll world [bootstrap] opt opt.opt install
- * `make -f Makefile.nt install` will install FlexDLL by placing `flexlink.exe`
+ * `make install` will install FlexDLL by placing `flexlink.exe`
(and the default manifest file for the Microsoft port) in `bin/` and the
FlexDLL object files in `lib/`.
- * If you don't include `make -f Makefile.nt opt.opt`, `flexlink.exe` will be a
- bytecode program. `make -f Makefile.nt install` always installs the "best"
+ * If you don't include `make opt.opt`, `flexlink.exe` will be a
+ bytecode program. `make install` always installs the "best"
`flexlink.exe` (i.e. there is never a `flexlink.opt.exe` installed).
* If you have populated `flexdll/`, you *must* run
- `make -f Makefile.nt flexdll`. If you wish to revert to using an externally
+ `make flexdll`. If you wish to revert to using an externally
installed FlexDLL, you must erase the contents of `flexdll/` before
compiling.
-4.04.0
+4.05.0+rc1
# The version string is the first line of this file.
# It must be in the format described in stdlib/sys.mli
platform:
- x64
+image: Visual Studio 2015
+
branches:
only:
- trunk
+ - 4.05
# Do a shallow clone of the repo to speed up the build
clone_depth: 1
environment:
global:
- CYG_ROOT: C:/cygwin
+ CYG_ROOT: C:/cygwin64
CYG_MIRROR: http://mirrors.kernel.org/sourceware/cygwin/
- CYG_CACHE: C:/cygwin/var/cache/setup
+ CYG_CACHE: C:/cygwin64/var/cache/setup
+ OCAMLRUNPARAM: v=0,b
OCAMLROOT: "%PROGRAMFILES%/OCaml"
+ OCAMLROOT2: "%PROGRAMFILES%/OCaml-mingw32"
cache:
- - C:\cygwin\var\cache\setup
+ - C:\cygwin64\var\cache\setup
install:
- - mkdir "%OCAMLROOT%"
- - mkdir "%OCAMLROOT%/bin"
- mkdir "%OCAMLROOT%/bin/flexdll"
- - appveyor DownloadFile "http://alain.frisch.fr/flexdll/flexdll-bin-0.34.zip" -FileName "flexdll.zip"
+ - appveyor DownloadFile "http://alain.frisch.fr/flexdll/flexdll-bin-0.35.zip" -FileName "flexdll.zip"
+ - appveyor DownloadFile "http://alain.frisch.fr/flexdll/flexdll-0.35.tar.gz" -FileName "flexdll.tar.gz"
- cinst 7zip.commandline
- - 7za x -y flexdll.zip
- - for %%F in (*.c *.h *.exe *.o *.obj) do copy %%F "%OCAMLROOT%\bin\flexdll"
+ - mkdir flexdll-tmp
+ - cd flexdll-tmp
+ - 7za x -y ..\flexdll.zip
+ - for %%F in (flexdll.h flexlink.exe default_amd64.manifest) do copy %%F "%OCAMLROOT%\bin\flexdll"
+ - cd ..
# Make sure the Cygwin path comes before the Git one (otherwise
# cygpath behaves crazily), but after the MSVC one.
- - set Path=C:\cygwin\bin;%Path%
- - '"%CYG_ROOT%\setup-x86.exe" -qnNdO -R "%CYG_ROOT%" -s "%CYG_MIRROR%" -l "%CYG_CACHE%" -P diffutils -P dos2unix -P gcc-core -P make -P ncurses >NUL'
+ - set Path=C:\cygwin64\bin;%OCAMLROOT%\bin\flexdll;%Path%
+ - '%CYG_ROOT%\bin\bash -lc "cygcheck -dc cygwin"'
+ - '"%CYG_ROOT%\setup-x86_64.exe" -qgnNdO -R "%CYG_ROOT%" -s "%CYG_MIRROR%" -l "%CYG_CACHE%" -P diffutils -P make -P mingw64-i686-gcc-core >NUL'
- '%CYG_ROOT%\bin\bash -lc "cygcheck -dc cygwin"'
- - call "C:\Program Files\Microsoft SDKs\Windows\v7.1\Bin\SetEnv.cmd" /x64
- - set Path=%OCAMLROOT%\bin;%OCAMLROOT%\bin\flexdll;%Path%
+ - set OCAML_PREV_PATH=%PATH%
+ - set OCAML_PREV_LIB=%LIB%
+ - set OCAML_PREV_INCLUDE=%INCLUDE%
+ - call "C:\Program Files (x86)\Microsoft Visual Studio 14.0\VC\bin\amd64\vcvars64.bat"
build_script:
- - set PFPATH=%PROGRAMFILES%
- - set FLEXDLLDIR=%OCAMLROOT%\bin\flexdll
- - echo VCPATH="`cygpath -p '%Path%'`" > %CYG_ROOT%\tmp\msenv
- - echo LIB="%LIB%" >> %CYG_ROOT%\tmp\msenv
- - echo LIBPATH="%LIBPATH%" >> %CYG_ROOT%\tmp\msenv
- - echo INCLUDE="%INCLUDE%;%FLEXDLLDIR%" >> %CYG_ROOT%\tmp\msenv
- - echo FLPATH="`cygpath '%FLEXDLLDIR%'`" >> %CYG_ROOT%\tmp\msenv
- - echo PATH="$VCPATH:$FLPATH:$PATH" >> %CYG_ROOT%\tmp\msenv
- - echo export PATH LIB LIBPATH INCLUDE >> %CYG_ROOT%\tmp\msenv
- - echo export OCAMLBUILD_FIND=/usr/bin/find >> %CYG_ROOT%\tmp\msenv
- - "%CYG_ROOT%/bin/bash -lc \"tr -d '\\r' </tmp/msenv > ~/.msenv64\""
- - "%CYG_ROOT%/bin/bash -lc \"echo '. ~/.msenv64' >> ~/.bash_profile\""
+ - "%CYG_ROOT%/bin/bash -lc \"echo 'eval $($APPVEYOR_BUILD_FOLDER/tools/msvs-promote-path)' >> ~/.bash_profile\""
- '%CYG_ROOT%/bin/bash -lc "$APPVEYOR_BUILD_FOLDER/appveyor_build.sh"'
+ - set PATH=%OCAML_PREV_PATH%
+ - set LIB=%OCAML_PREV_LIB%
+ - set INCLUDE=%OCAML_PREV_INCLUDE%
+ - call "C:\Program Files\Microsoft SDKs\Windows\v7.1\Bin\SetEnv.cmd" /x86
+ - '%CYG_ROOT%/bin/bash -lc "$APPVEYOR_BUILD_FOLDER/appveyor_build.sh msvc32-only"'
test_script:
- - ocamlc -version
+ - set PATH=%OCAML_PREV_PATH%
+ - set LIB=%OCAML_PREV_LIB%
+ - set INCLUDE=%OCAML_PREV_INCLUDE%
+ - call "C:\Program Files (x86)\Microsoft Visual Studio 14.0\VC\bin\amd64\vcvars64.bat"
+ - '%APPVEYOR_BUILD_FOLDER%\ocamlc.opt -version'
- set CAML_LD_LIBRARY_PATH=%OCAMLROOT%/lib/stublibs
- - '%CYG_ROOT%/bin/bash -lc "cd $APPVEYOR_BUILD_FOLDER && make -f Makefile.nt tests"'
+ - '%CYG_ROOT%/bin/bash -lc "cd $APPVEYOR_BUILD_FOLDER && make tests"'
+ - '%CYG_ROOT%/bin/bash -lc "cd $APPVEYOR_BUILD_FOLDER/../build-mingw32 && make tests"'
+ - '%CYG_ROOT%/bin/bash -lc "cd $APPVEYOR_BUILD_FOLDER && make install"'
+ - '%CYG_ROOT%/bin/bash -lc "cd $APPVEYOR_BUILD_FOLDER/../build-mingw32 && make install"'
fi
}
+PREFIX="C:/Program Files/OCaml"
+
+wmic cpu get name
+
+if [[ $1 = "msvc32-only" ]] ; then
+ cd $APPVEYOR_BUILD_FOLDER/flexdll-0.35
+ make MSVC_DETECT=0 CHAINS=msvc MSVC_FLAGS="-nologo -MD -D_CRT_NO_DEPRECATE -GS- -WX" support
+ cp flexdll*_msvc.obj "$PREFIX/bin/flexdll"
+
+ cd $APPVEYOR_BUILD_FOLDER/../build-msvc32
+ cp config/m-nt.h config/m.h
+ cp config/s-nt.h config/s.h
+
+ eval $(tools/msvs-promote-path)
+
+ PREFIX="C:/Program Files/OCaml-msmvc32"
+ echo "Edit config/Makefile to set PREFIX=$PREFIX"
+ sed -e "s|PREFIX=.*|PREFIX=$PREFIX|" -e "/\(BYTE\|NATIVE\)CCCOMPOPTS=./s/\r\?$/ -WX\0/" config/Makefile.msvc > config/Makefile
+
+ run "make world" make world
+ run "make runtimeopt" make runtimeopt
+ run "make -C otherlibs/systhreads libthreadsnat.lib" make -C otherlibs/systhreads libthreadsnat.lib
+
+ exit 0
+fi
+
+cd $APPVEYOR_BUILD_FOLDER
+
+git worktree add ../build-mingw32 -b appveyor-build-mingw32
+git worktree add ../build-msvc32 -b appveyor-build-msvc32
+
+cd ../build-mingw32
+git submodule update --init flexdll
+
cd $APPVEYOR_BUILD_FOLDER
+tar -xzf flexdll.tar.gz
+cd flexdll-0.35
+make MSVC_DETECT=0 CHAINS=msvc64 support
+cp flexdll*_msvc64.obj "$PREFIX/bin/flexdll"
+cd ..
+
cp config/m-nt.h config/m.h
cp config/s-nt.h config/s.h
-#cp config/Makefile.msvc config/Makefile
-cp config/Makefile.msvc64 config/Makefile
-PREFIX="C:/Program Files/OCaml"
-echo "Edit config/Makefile so set PREFIX=$PREFIX"
-cp config/Makefile config/Makefile.bak
-sed -e "s|PREFIX=.*|PREFIX=$PREFIX|" config/Makefile.bak > config/Makefile
+echo "Edit config/Makefile to set PREFIX=$PREFIX"
+sed -e "s|PREFIX=.*|PREFIX=$PREFIX|" -e "/\(BYTE\|NATIVE\)CCCOMPOPTS=./s/\r\?$/ -WX\0/" config/Makefile.msvc64 > config/Makefile
+#run "Content of config/Makefile" cat config/Makefile
+
+run "make world" make world
+run "make bootstrap" make bootstrap
+run "make opt" make opt
+run "make opt.opt" make opt.opt
+
+cd ../build-mingw32
+
+cp config/m-nt.h config/m.h
+cp config/s-nt.h config/s.h
+
+PREFIX="C:/Program Files/OCaml-mingw32"
+echo "Edit config/Makefile to set PREFIX=$PREFIX"
+sed -e "s|PREFIX=.*|PREFIX=$PREFIX|" -e "/\(BYTE\|NATIVE\)CCCOMPOPTS=./s/\r\?$/ -Werror\0/" config/Makefile.mingw > config/Makefile
#run "Content of config/Makefile" cat config/Makefile
-run "make world" make -f Makefile.nt world
-run "make bootstrap" make -f Makefile.nt bootstrap
-run "make opt" make -f Makefile.nt opt
-run "make opt.opt" make -f Makefile.nt opt.opt
-run "make install" make -f Makefile.nt install
+run "make flexdll" make flexdll
+run "make world.opt" make world.opt
| Iloop(body) ->
{i with desc = Iloop(self#cse empty_numbering body);
next = self#cse empty_numbering i.next}
- | Icatch(nfail, body, handler) ->
- {i with desc = Icatch(nfail, self#cse n body,
- self#cse empty_numbering handler);
+ | Icatch(rec_flag, handlers, body) ->
+ let aux (nfail, handler) =
+ nfail, self#cse empty_numbering handler
+ in
+ {i with desc = Icatch(rec_flag, List.map aux handlers, self#cse n body);
next = self#cse empty_numbering i.next}
| Itrywith(body, handler) ->
{i with desc = Itrywith(self#cse n body,
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Stephen Dolan, University of Cambridge *)
+(* *)
+(* Copyright 2016 Stephen Dolan. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Insert instrumentation for afl-fuzz *)
+
+open Lambda
+open Cmm
+
+let afl_area_ptr = Cconst_symbol "caml_afl_area_ptr"
+let afl_prev_loc = Cconst_symbol "caml_afl_prev_loc"
+let afl_map_size = 1 lsl 16
+
+let rec with_afl_logging b =
+ if !Clflags.afl_inst_ratio < 100 &&
+ Random.int 100 >= !Clflags.afl_inst_ratio then instrument b else
+ let instrumentation =
+ (* The instrumentation that afl-fuzz requires is:
+
+ cur_location = <COMPILE_TIME_RANDOM>;
+ shared_mem[cur_location ^ prev_location]++;
+ prev_location = cur_location >> 1;
+
+ See http://lcamtuf.coredump.cx/afl/technical_details.txt or
+ docs/technical_details.txt in afl-fuzz source for for a full
+ description of what's going on. *)
+ let cur_location = Random.int afl_map_size in
+ let cur_pos = Ident.create "pos" in
+ let afl_area = Ident.create "shared_mem" in
+ let op oper args = Cop (oper, args, Debuginfo.none) in
+ Clet(afl_area, op (Cload (Word_int, Asttypes.Mutable)) [afl_area_ptr],
+ Clet(cur_pos, op Cxor [op (Cload (Word_int, Asttypes.Mutable))
+ [afl_prev_loc]; Cconst_int cur_location],
+ Csequence(
+ op (Cstore(Byte_unsigned, Assignment))
+ [op Cadda [Cvar afl_area; Cvar cur_pos];
+ op Cadda [op (Cload (Byte_unsigned, Asttypes.Mutable))
+ [op Cadda [Cvar afl_area; Cvar cur_pos]];
+ Cconst_int 1]],
+ op (Cstore(Word_int, Assignment))
+ [afl_prev_loc; Cconst_int (cur_location lsr 1)]))) in
+ Csequence(instrumentation, instrument b)
+
+and instrument = function
+ (* these cases add logging, as they may be targets of conditional branches *)
+ | Cifthenelse (cond, t, f) ->
+ Cifthenelse (instrument cond, with_afl_logging t, with_afl_logging f)
+ | Cloop e ->
+ Cloop (with_afl_logging e)
+ | Ctrywith (e, ex, handler) ->
+ Ctrywith (instrument e, ex, with_afl_logging handler)
+ | Cswitch (e, cases, handlers, dbg) ->
+ Cswitch (instrument e, cases, Array.map with_afl_logging handlers, dbg)
+
+ (* these cases add no logging, but instrument subexpressions *)
+ | Clet (v, e, body) -> Clet (v, instrument e, instrument body)
+ | Cassign (v, e) -> Cassign (v, instrument e)
+ | Ctuple es -> Ctuple (List.map instrument es)
+ | Cop (op, es, dbg) -> Cop (op, List.map instrument es, dbg)
+ | Csequence (e1, e2) -> Csequence (instrument e1, instrument e2)
+ | Ccatch (isrec, cases, body) ->
+ Ccatch (isrec,
+ List.map (fun (nfail, ids, e) -> nfail, ids, instrument e) cases,
+ instrument body)
+ | Cexit (ex, args) -> Cexit (ex, List.map instrument args)
+
+ (* these are base cases and have no logging *)
+ | Cconst_int _ | Cconst_natint _ | Cconst_float _
+ | Cconst_symbol _ | Cconst_pointer _ | Cconst_natpointer _
+ | Cblockheader _ | Cvar _ as c -> c
+
+let instrument_function c =
+ with_afl_logging c
+
+let instrument_initialiser c =
+ (* Each instrumented module calls caml_setup_afl at
+ initialisation, which is a no-op on the second and subsequent
+ calls *)
+ with_afl_logging
+ (Csequence
+ (Cop (Cextcall ("caml_setup_afl", typ_int, false, None),
+ [Cconst_int 0],
+ Debuginfo.none),
+ c))
--- /dev/null
+(* Instrumentation for afl-fuzz *)
+
+val instrument_function : Cmm.expression -> Cmm.expression
+val instrument_initialiser : Cmm.expression -> Cmm.expression
| Ispecific spec ->
begin match spec with
| Ilea _ -> Op_pure
- | Istore_int(_, _, is_asg) | Istore_symbol(_, _, is_asg) -> Op_store is_asg
+ | Istore_int(_, _, is_asg) -> Op_store is_asg
| Ioffset_loc(_, _) -> Op_store true
| Ifloatarithmem _ | Ifloatsqrtf _ -> Op_load
| Ibswap _ | Isqrtf -> super#class_of_operation op
Ilea of addressing_mode (* "lea" gives scaled adds *)
| Istore_int of nativeint * addressing_mode * bool
(* Store an integer constant *)
- | Istore_symbol of string * addressing_mode * bool (* Store a symbol *)
| Ioffset_loc of int * addressing_mode (* Add a constant to a location *)
| Ifloatarithmem of float_operation * addressing_mode
(* Float arith operation with memory *)
fprintf ppf "[%a] := %nd %s"
(print_addressing printreg addr) arg n
(if is_assign then "(assign)" else "(init)")
- | Istore_symbol(lbl, addr, is_assign) ->
- fprintf ppf "[%a] := \"%s\" %s"
- (print_addressing printreg addr) arg lbl
- (if is_assign then "(assign)" else "(init)")
| Ioffset_loc(n, addr) ->
fprintf ppf "[%a] +:= %i" (print_addressing printreg addr) arg n
| Isqrtf ->
(Array.sub arg 1 (Array.length arg - 1))
| Ibswap i ->
fprintf ppf "bswap_%i %a" i printreg arg.(0)
+
+let win64 =
+ match Config.system with
+ | "win64" | "mingw64" | "cygwin" -> true
+ | _ -> false
| _ -> ()
)
live;
- frame_descriptors :=
- { fd_lbl = lbl;
- fd_frame_size = frame_size();
- fd_live_offset = !live_offset;
- fd_raise = raise_;
- fd_debuginfo = dbg } :: !frame_descriptors;
+ record_frame_descr ~label:lbl ~frame_size:(frame_size())
+ ~live_offset:!live_offset ~raise_frame:raise_ dbg;
lbl
let record_frame ?label live raise_ dbg =
I.lea (addressing addr NONE i 0) (res i 0)
| Lop(Ispecific(Istore_int(n, addr, _))) ->
I.mov (nat n) (addressing addr QWORD i 0)
- | Lop(Ispecific(Istore_symbol(s, addr, _))) ->
- assert (not !Clflags.pic_code && not !Clflags.dlcode);
- add_used_symbol s;
- load_symbol_addr s (addressing addr QWORD i 0)
| Lop(Ispecific(Ioffset_loc(n, addr))) ->
I.add (int n) (addressing addr QWORD i 0)
| Lop(Ispecific(Ifloatarithmem(op, addr))) ->
end;
- if !Clflags.dlcode then begin
+ if !Clflags.dlcode || Arch.win64 then begin
(* from amd64.S; could emit these constants on demand *)
begin match system with
| S_macosx -> D.section ["__TEXT";"__literal16"] None ["16byte_literals"]
(* Which ABI to use *)
-let win64 =
- match Config.system with
- | "win64" | "mingw64" | "cygwin" -> true
- | _ -> false
+let win64 = Arch.win64
(* Registers available for register allocation *)
then (arg, res)
else super#reload_operation op arg res
| Iconst_symbol _ ->
- if !Clflags.pic_code || !Clflags.dlcode
+ if !Clflags.pic_code || !Clflags.dlcode || Arch.win64
then super#reload_operation op arg res
else (arg, res)
| _ -> (* Other operations: all args and results in registers *)
match exp with
Cconst_symbol s when not !Clflags.dlcode ->
(Asymbol s, 0)
- | Cop((Caddi | Caddv | Cadda), [arg; Cconst_int m]) ->
+ | Cop((Caddi | Caddv | Cadda), [arg; Cconst_int m], _) ->
let (a, n) = select_addr arg in (a, n + m)
- | Cop(Csubi, [arg; Cconst_int m]) ->
+ | Cop(Csubi, [arg; Cconst_int m], _) ->
let (a, n) = select_addr arg in (a, n - m)
- | Cop((Caddi | Caddv | Cadda), [Cconst_int m; arg]) ->
+ | Cop((Caddi | Caddv | Cadda), [Cconst_int m; arg], _) ->
let (a, n) = select_addr arg in (a, n + m)
- | Cop(Clsl, [arg; Cconst_int(1|2|3 as shift)]) ->
+ | Cop(Clsl, [arg; Cconst_int(1|2|3 as shift)], _) ->
begin match select_addr arg with
(Alinear e, n) -> (Ascale(e, 1 lsl shift), n lsl shift)
| _ -> (Alinear exp, 0)
end
- | Cop(Cmuli, [arg; Cconst_int(2|4|8 as mult)]) ->
+ | Cop(Cmuli, [arg; Cconst_int(2|4|8 as mult)], _) ->
begin match select_addr arg with
(Alinear e, n) -> (Ascale(e, mult), n * mult)
| _ -> (Alinear exp, 0)
end
- | Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg]) ->
+ | Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg], _) ->
begin match select_addr arg with
(Alinear e, n) -> (Ascale(e, mult), n * mult)
| _ -> (Alinear exp, 0)
end
- | Cop((Caddi | Caddv | Cadda), [arg1; arg2]) ->
+ | Cop((Caddi | Caddv | Cadda), [arg1; arg2], _) ->
begin match (select_addr arg1, select_addr arg2) with
((Alinear e1, n1), (Alinear e2, n2)) ->
(Aadd(e1, e2), n1 + n2)
(* Other instructions are regular *)
| _ -> raise Use_default
+(* If you update [inline_ops], you may need to update [is_simple_expr] and/or
+ [effects_of], below. *)
let inline_ops =
[ "sqrt"; "caml_bswap16_direct"; "caml_int32_direct_bswap";
"caml_int64_direct_bswap"; "caml_nativeint_direct_bswap" ]
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! effects_of e =
+ match e with
+ | Cop(Cextcall(fn, _, _, _), args, _)
+ when List.mem fn inline_ops ->
+ Selectgen.Effect_and_coeffect.join_list_map args self#effects_of
+ | _ ->
+ super#effects_of e
+
method select_addressing _chunk exp =
let (a, d) = select_addr exp in
(* PR#4625: displacement must be a signed 32-bit immediate *)
(Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple [])
| Cconst_natpointer n when self#is_immediate_natint n ->
(Ispecific(Istore_int(n, addr, is_assign)), Ctuple [])
- | Cconst_symbol s when not (!Clflags.pic_code || !Clflags.dlcode) ->
- (Ispecific(Istore_symbol(s, addr, is_assign)), Ctuple [])
| _ ->
super#select_store is_assign addr exp
-method! select_operation op args =
+method! select_operation op args dbg =
match op with
(* Recognize the LEA instruction *)
Caddi | Caddv | Cadda | Csubi ->
- begin match self#select_addressing Word_int (Cop(op, args)) with
+ begin match self#select_addressing Word_int (Cop(op, args, dbg)) with
(Iindexed _, _)
- | (Iindexed2 0, _) -> super#select_operation op args
+ | (Iindexed2 0, _) -> super#select_operation op args dbg
| (addr, arg) -> (Ispecific(Ilea addr), [arg])
end
(* Recognize float arithmetic with memory. *)
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])] ->
+ [Cop(Cload ((Double|Double_u as chunk), _), [loc], _dbg)] ->
let (addr, arg) = self#select_addressing chunk loc in
(Ispecific(Ifloatsqrtf addr), [arg])
| [arg] ->
(* Recognize store instructions *)
| Cstore ((Word_int|Word_val as chunk), _init) ->
begin match args with
- [loc; Cop(Caddi, [Cop(Cload _, [loc']); Cconst_int n])]
+ [loc; Cop(Caddi, [Cop(Cload _, [loc'], _); Cconst_int n], _)]
when loc = loc' && self#is_immediate n ->
let (addr, arg) = self#select_addressing chunk loc in
(Ispecific(Ioffset_loc(n, addr)), [arg])
| _ ->
- super#select_operation op args
+ super#select_operation op args dbg
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 ->
(Iintop Imulh, args)
- | _ -> super#select_operation op args
+ | _ -> super#select_operation op args dbg
(* Recognize float arithmetic with mem *)
method select_floatarith commutative regular_op mem_op args =
match args with
- [arg1; Cop(Cload (Double|Double_u as chunk), [loc2])] ->
+ [arg1; Cop(Cload ((Double|Double_u as chunk), _), [loc2], _)] ->
let (addr, arg2) = self#select_addressing chunk loc2 in
(Ispecific(Ifloatarithmem(mem_op, addr)),
[arg1; arg2])
- | [Cop(Cload (Double|Double_u as chunk), [loc1]); arg2] when commutative ->
+ | [Cop(Cload ((Double|Double_u as chunk), _), [loc1], _); arg2]
+ when commutative ->
let (addr, arg1) = self#select_addressing chunk loc1 in
(Ispecific(Ifloatarithmem(mem_op, addr)),
[arg2; arg1])
Misc.fatal_error ("bad GC root " ^ Reg.name r)
| _ -> ())
live;
- frame_descriptors :=
- { fd_lbl = lbl;
- fd_frame_size = frame_size();
- fd_live_offset = !live_offset;
- fd_raise = raise_;
- fd_debuginfo = dbg } :: !frame_descriptors;
+ record_frame_descr ~label:lbl ~frame_size:(frame_size())
+ ~live_offset:!live_offset ~raise_frame:raise_ dbg;
lbl
let record_frame ?label live raise_ dbg =
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)
+ | Cop(Cextcall("caml_bswap16_direct", _, _, _), args, _)
when !arch >= ARMv6T2 ->
List.for_all self#is_simple_expr args
- | Cop(Cextcall("caml_int32_direct_bswap", _,_,_,_), args)
+ | Cop(Cextcall("caml_int32_direct_bswap",_,_,_), args, _)
when !arch >= ARMv6 ->
List.for_all self#is_simple_expr args
| e -> super#is_simple_expr e
+method! effects_of e =
+ match e with
+ | Cop(Cextcall("sqrt", _, _, _), args, _) when !fpu >= VFPv2 ->
+ Selectgen.Effect_and_coeffect.join_list_map args self#effects_of
+ | Cop(Cextcall("caml_bswap16_direct", _, _, _), args, _)
+ when !arch >= ARMv6T2 ->
+ Selectgen.Effect_and_coeffect.join_list_map args self#effects_of
+ | Cop(Cextcall("caml_int32_direct_bswap",_,_,_), args, _)
+ when !arch >= ARMv6 ->
+ Selectgen.Effect_and_coeffect.join_list_map args self#effects_of
+ | e -> super#effects_of e
+
method select_addressing chunk = function
- | Cop((Cadda | Caddv), [arg; Cconst_int n])
+ | Cop((Cadda | Caddv), [arg; Cconst_int n], _)
when is_offset chunk n ->
(Iindexed n, arg)
- | Cop((Cadda | Caddv as op), [arg1; Cop(Caddi, [arg2; Cconst_int n])])
+ | Cop((Cadda | Caddv as op), [arg1; Cop(Caddi, [arg2; Cconst_int n], _)], dbg)
when is_offset chunk n ->
- (Iindexed n, Cop(op, [arg1; arg2]))
+ (Iindexed n, Cop(op, [arg1; arg2], dbg))
| arg ->
(Iindexed 0, arg)
-method select_shift_arith op arithop arithrevop args =
+method select_shift_arith op dbg arithop arithrevop args =
match args with
- [arg1; Cop(Clsl | Clsr | Casr as op, [arg2; Cconst_int n])]
+ [arg1; Cop(Clsl | Clsr | Casr as op, [arg2; Cconst_int n], _)]
when n > 0 && n < 32 ->
(Ispecific(Ishiftarith(arithop, select_shiftop op, n)), [arg1; arg2])
- | [Cop(Clsl | Clsr | Casr as op, [arg1; Cconst_int n]); arg2]
+ | [Cop(Clsl | Clsr | Casr as op, [arg1; Cconst_int n], _); arg2]
when n > 0 && n < 32 ->
(Ispecific(Ishiftarith(arithrevop, select_shiftop op, n)), [arg2; arg1])
| args ->
- begin match super#select_operation op args with
+ begin match super#select_operation op args dbg with
(* Recognize multiply high and add *)
- (Iintop Iadd, [Cop(Cmulhi, args); arg3])
- | (Iintop Iadd, [arg3; Cop(Cmulhi, args)]) as op_args
+ (Iintop Iadd, [Cop(Cmulhi, args, _); arg3])
+ | (Iintop Iadd, [arg3; Cop(Cmulhi, args, _)]) as op_args
when !arch >= ARMv6 ->
- begin match self#select_operation Cmulhi args with
+ begin match self#select_operation Cmulhi args dbg with
(Iintop Imulh, [arg1; arg2]) ->
(Ispecific Imulhadd, [arg1; arg2; arg3])
| _ -> op_args
end
(* Recognize multiply and add *)
- | (Iintop Iadd, [Cop(Cmuli, args); arg3])
- | (Iintop Iadd, [arg3; Cop(Cmuli, args)]) as op_args ->
- begin match self#select_operation Cmuli args with
+ | (Iintop Iadd, [Cop(Cmuli, args, _); arg3])
+ | (Iintop Iadd, [arg3; Cop(Cmuli, args, _)]) as op_args ->
+ begin match self#select_operation Cmuli args dbg with
(Iintop Imul, [arg1; arg2]) ->
(Ispecific Imuladd, [arg1; arg2; arg3])
| _ -> op_args
end
(* Recognize multiply and subtract *)
- | (Iintop Isub, [arg3; Cop(Cmuli, args)]) as op_args
+ | (Iintop Isub, [arg3; Cop(Cmuli, args, _)]) as op_args
when !arch > ARMv6 ->
- begin match self#select_operation Cmuli args with
+ begin match self#select_operation Cmuli args dbg with
(Iintop Imul, [arg1; arg2]) ->
(Ispecific Imulsub, [arg1; arg2; arg3])
| _ -> op_args
method private iextcall (func, alloc) =
Iextcall { func; alloc; label_after = Cmm.new_label (); }
-method! select_operation op args =
+method! select_operation op args dbg =
match (op, args) with
(* Recognize special shift arithmetic *)
((Caddv | Cadda | Caddi), [arg; Cconst_int n])
when n < 0 && self#is_immediate (-n) ->
(Iintop_imm(Isub, -n), [arg])
| ((Caddv | Cadda | Caddi as op), args) ->
- self#select_shift_arith op Ishiftadd Ishiftadd args
+ self#select_shift_arith op dbg Ishiftadd Ishiftadd args
| (Csubi, [arg; Cconst_int n])
when n < 0 && self#is_immediate (-n) ->
(Iintop_imm(Iadd, -n), [arg])
when self#is_immediate n ->
(Ispecific(Irevsubimm n), [arg])
| (Csubi as op, args) ->
- self#select_shift_arith op Ishiftsub Ishiftsubrev args
+ self#select_shift_arith op dbg Ishiftsub Ishiftsubrev args
| (Cand as op, args) ->
- self#select_shift_arith op Ishiftand Ishiftand args
+ self#select_shift_arith op dbg Ishiftand Ishiftand args
| (Cor as op, args) ->
- self#select_shift_arith op Ishiftor Ishiftor args
+ self#select_shift_arith op dbg Ishiftor Ishiftor args
| (Cxor as op, args) ->
- self#select_shift_arith op Ishiftxor Ishiftxor args
- | (Ccheckbound _, [Cop(Clsl | Clsr | Casr as op, [arg1; Cconst_int n]); arg2])
+ self#select_shift_arith op dbg Ishiftxor Ishiftxor args
+ | (Ccheckbound,
+ [Cop(Clsl | Clsr | Casr as op, [arg1; Cconst_int n], _); arg2])
when n > 0 && n < 32 ->
(Ispecific(Ishiftcheckbound(select_shiftop op, n)), [arg1; arg2])
(* ARM does not support immediate operands for multiplication *)
(* See above for fix up of return register *)
(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)
+ | (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
+ | (op, args) when !fpu = Soft -> self#select_operation_softfp op args dbg
(* Select operations for VFPv{2,3} *)
- | (op, args) -> self#select_operation_vfpv3 op args
+ | (op, args) -> self#select_operation_vfpv3 op args dbg
-method private select_operation_softfp op args =
+method private select_operation_softfp op args dbg =
match (op, args) with
(* Turn floating-point operations into runtime ABI calls *)
| (Caddf, args) -> (self#iextcall("__aeabi_dadd", false), 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, None), args)])
+ [Cop(Cextcall(func, typ_int, false, None), args, dbg)])
(* Add coercions around loads and stores of 32-bit floats *)
- | (Cload Single, args) ->
- (self#iextcall("__aeabi_f2d", false), [Cop(Cload Word_int, args)])
+ | (Cload (Single, mut), args) ->
+ (self#iextcall("__aeabi_f2d", false),
+ [Cop(Cload (Word_int, mut), args, dbg)])
| (Cstore (Single, init), [arg1; arg2]) ->
let arg2' =
- Cop(Cextcall("__aeabi_d2f", typ_int, false, Debuginfo.none, None),
- [arg2]) in
- self#select_operation (Cstore (Word_int, init)) [arg1; arg2']
+ Cop(Cextcall("__aeabi_d2f", typ_int, false, None), [arg2], dbg) in
+ self#select_operation (Cstore (Word_int, init)) [arg1; arg2'] dbg
(* Other operations are regular *)
- | (op, args) -> super#select_operation op args
+ | (op, args) -> super#select_operation op args dbg
-method private select_operation_vfpv3 op args =
+method private select_operation_vfpv3 op args dbg =
match (op, args) with
(* Recognize floating-point negate and multiply *)
- (Cnegf, [Cop(Cmulf, args)]) ->
+ (Cnegf, [Cop(Cmulf, args, _)]) ->
(Ispecific Inegmulf, args)
(* Recognize floating-point multiply and add *)
- | (Caddf, [arg; Cop(Cmulf, args)])
- | (Caddf, [Cop(Cmulf, args); arg]) ->
+ | (Caddf, [arg; Cop(Cmulf, args, _)])
+ | (Caddf, [Cop(Cmulf, args, _); arg]) ->
(Ispecific Imuladdf, arg :: args)
(* Recognize floating-point negate, multiply and subtract *)
- | (Csubf, [Cop(Cnegf, [arg]); Cop(Cmulf, args)])
- | (Csubf, [Cop(Cnegf, [Cop(Cmulf, args)]); arg]) ->
+ | (Csubf, [Cop(Cnegf, [arg], _); Cop(Cmulf, args, _)])
+ | (Csubf, [Cop(Cnegf, [Cop(Cmulf, args, _)], _); arg]) ->
(Ispecific Inegmulsubf, arg :: args)
(* Recognize floating-point negate, multiply and add *)
- | (Csubf, [arg; Cop(Cmulf, args)]) ->
+ | (Csubf, [arg; Cop(Cmulf, args, _)]) ->
(Ispecific Inegmuladdf, arg :: args)
(* Recognize multiply and subtract *)
- | (Csubf, [Cop(Cmulf, args); arg]) ->
+ | (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
+ | (op, args) -> super#select_operation op args dbg
method! select_condition = function
(* Turn floating-point comparisons into runtime ABI calls *)
- Cop(Ccmpf _ as op, args) when !fpu = Soft ->
- begin match self#select_operation_softfp op args with
+ Cop(Ccmpf _ as op, args, dbg) when !fpu = Soft ->
+ begin match self#select_operation_softfp op args dbg with
(Iintop_imm(Icomp(Iunsigned Ceq), 0), [arg]) -> (Ifalsetest, arg)
| (Iintop_imm(Icomp(Iunsigned Cne), 0), [arg]) -> (Itruetest, arg)
| _ -> assert false
Misc.fatal_error ("bad GC root " ^ Reg.name r)
| _ -> ())
live;
- frame_descriptors :=
- { fd_lbl = lbl;
- fd_frame_size = frame_size();
- fd_live_offset = !live_offset;
- fd_raise = raise_;
- fd_debuginfo = dbg } :: !frame_descriptors;
+ record_frame_descr ~label:lbl ~frame_size:(frame_size())
+ ~live_offset:!live_offset ~raise_frame:raise_ dbg;
lbl
let record_frame ?label live raise_ dbg =
let is_logical_immediate n =
n <> 0 && n <> -1 && run_automata 64 0 n
+(* If you update [inline_ops], you may need to update [is_simple_expr] and/or
+ [effects_of], below. *)
let inline_ops =
[ "sqrt"; "caml_bswap16_direct"; "caml_int32_direct_bswap";
"caml_int64_direct_bswap"; "caml_nativeint_direct_bswap" ]
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
+method! effects_of e =
+ match e with
+ | Cop(Cextcall (fn, _, _, _), args, _) when List.mem fn inline_ops ->
+ Selectgen.Effect_and_coeffect.join_list_map args self#effects_of
+ | e -> super#effects_of e
+
method select_addressing chunk = function
- | Cop((Caddv | Cadda), [Cconst_symbol s; Cconst_int n])
+ | Cop((Caddv | Cadda), [Cconst_symbol s; Cconst_int n], _)
when use_direct_addressing s ->
(Ibased(s, n), Ctuple [])
- | Cop((Caddv | Cadda), [arg; Cconst_int n])
+ | Cop((Caddv | Cadda), [arg; Cconst_int n], _)
when is_offset chunk n ->
(Iindexed n, arg)
- | Cop((Caddv | Cadda as op), [arg1; Cop(Caddi, [arg2; Cconst_int n])])
+ | Cop((Caddv | Cadda as op), [arg1; Cop(Caddi, [arg2; Cconst_int n], _)], dbg)
when is_offset chunk n ->
- (Iindexed n, Cop(op, [arg1; arg2]))
+ (Iindexed n, Cop(op, [arg1; arg2], dbg))
| Cconst_symbol s
when use_direct_addressing s ->
(Ibased(s, 0), Ctuple [])
| arg ->
(Iindexed 0, arg)
-method! select_operation op args =
+method! select_operation op args dbg =
match op with
(* Integer addition *)
| Caddi | Caddv | Cadda ->
((if n >= 0 then Iintop_imm(Iadd, n) else Iintop_imm(Isub, -n)),
[arg])
(* Shift-add *)
- | [arg1; Cop(Clsl, [arg2; Cconst_int n])] when n > 0 && n < 64 ->
+ | [arg1; Cop(Clsl, [arg2; Cconst_int n], _)] when n > 0 && n < 64 ->
(Ispecific(Ishiftarith(Ishiftadd, n)), [arg1; arg2])
- | [arg1; Cop(Casr, [arg2; Cconst_int n])] when n > 0 && n < 64 ->
+ | [arg1; Cop(Casr, [arg2; Cconst_int n], _)] when n > 0 && n < 64 ->
(Ispecific(Ishiftarith(Ishiftadd, -n)), [arg1; arg2])
- | [Cop(Clsl, [arg1; Cconst_int n]); arg2] when n > 0 && n < 64 ->
+ | [Cop(Clsl, [arg1; Cconst_int n], _); arg2] when n > 0 && n < 64 ->
(Ispecific(Ishiftarith(Ishiftadd, n)), [arg2; arg1])
- | [Cop(Casr, [arg1; Cconst_int n]); arg2] when n > 0 && n < 64 ->
+ | [Cop(Casr, [arg1; Cconst_int n], _); arg2] when n > 0 && n < 64 ->
(Ispecific(Ishiftarith(Ishiftadd, -n)), [arg2; arg1])
(* Multiply-add *)
- | [arg1; Cop(Cmuli, args2)] | [Cop(Cmuli, args2); arg1] ->
- begin match self#select_operation Cmuli args2 with
+ | [arg1; Cop(Cmuli, args2, dbg)] | [Cop(Cmuli, args2, dbg); arg1] ->
+ begin match self#select_operation Cmuli args2 dbg with
| (Iintop_imm(Ilsl, l), [arg3]) ->
(Ispecific(Ishiftarith(Ishiftadd, l)), [arg1; arg3])
| (Iintop Imul, [arg3; arg4]) ->
(Ispecific Imuladd, [arg3; arg4; arg1])
| _ ->
- super#select_operation op args
+ super#select_operation op args dbg
end
| _ ->
- super#select_operation op args
+ super#select_operation op args dbg
end
(* Integer subtraction *)
| Csubi ->
((if n >= 0 then Iintop_imm(Isub, n) else Iintop_imm(Iadd, -n)),
[arg])
(* Shift-sub *)
- | [arg1; Cop(Clsl, [arg2; Cconst_int n])] when n > 0 && n < 64 ->
+ | [arg1; Cop(Clsl, [arg2; Cconst_int n], _)] when n > 0 && n < 64 ->
(Ispecific(Ishiftarith(Ishiftsub, n)), [arg1; arg2])
- | [arg1; Cop(Casr, [arg2; Cconst_int n])] when n > 0 && n < 64 ->
+ | [arg1; Cop(Casr, [arg2; Cconst_int n], _)] when n > 0 && n < 64 ->
(Ispecific(Ishiftarith(Ishiftsub, -n)), [arg1; arg2])
(* Multiply-sub *)
- | [arg1; Cop(Cmuli, args2)] ->
- begin match self#select_operation Cmuli args2 with
+ | [arg1; Cop(Cmuli, args2, dbg)] ->
+ begin match self#select_operation Cmuli args2 dbg with
| (Iintop_imm(Ilsl, l), [arg3]) ->
(Ispecific(Ishiftarith(Ishiftsub, l)), [arg1; arg3])
| (Iintop Imul, [arg3; arg4]) ->
(Ispecific Imulsub, [arg3; arg4; arg1])
| _ ->
- super#select_operation op args
+ super#select_operation op args dbg
end
| _ ->
- super#select_operation op args
+ super#select_operation op args dbg
end
(* Checkbounds *)
- | Ccheckbound _ ->
+ | Ccheckbound ->
begin match args with
- | [Cop(Clsr, [arg1; Cconst_int n]); arg2] when n > 0 && n < 64 ->
+ | [Cop(Clsr, [arg1; Cconst_int n], _); arg2] when n > 0 && n < 64 ->
(Ispecific(Ishiftcheckbound { shift = n; label_after_error = None; }),
[arg1; arg2])
| _ ->
- super#select_operation op args
+ super#select_operation op args dbg
end
(* Integer multiplication *)
(* ARM does not support immediate operands for multiplication *)
(* Recognize floating-point negate and multiply *)
| Cnegf ->
begin match args with
- | [Cop(Cmulf, args)] -> (Ispecific Inegmulf, args)
- | _ -> super#select_operation op args
+ | [Cop(Cmulf, args, _)] -> (Ispecific Inegmulf, args)
+ | _ -> super#select_operation op args dbg
end
(* Recognize floating-point multiply and add/sub *)
| Caddf ->
begin match args with
- | [arg; Cop(Cmulf, args)] | [Cop(Cmulf, args); arg] ->
+ | [arg; Cop(Cmulf, args, _)] | [Cop(Cmulf, args, _); arg] ->
(Ispecific Imuladdf, arg :: args)
| _ ->
- super#select_operation op args
+ super#select_operation op args dbg
end
| Csubf ->
begin match args with
- | [arg; Cop(Cmulf, args)] ->
+ | [arg; Cop(Cmulf, args, _)] ->
(Ispecific Imulsubf, arg :: args)
- | [Cop(Cmulf, args); arg] ->
+ | [Cop(Cmulf, args, _); arg] ->
(Ispecific Inegmulsubf, arg :: args)
| _ ->
- super#select_operation op args
+ super#select_operation op args dbg
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 *)
| _ ->
- super#select_operation op args
+ super#select_operation op args dbg
method select_logical op = function
| [arg; Cconst_int n] when is_logical_immediate n ->
with Not_found ->
raise(Error(File_not_found name)) in
let (info, crc) = Compilenv.read_unit_info filename in
- info.ui_force_link <- !Clflags.link_everything;
+ info.ui_force_link <- info.ui_force_link || !Clflags.link_everything;
(* There is no need to keep the approximation in the .cmxa file,
since the compiler will go looking directly for .cmx files.
The linker, which is the only one that reads .cmxa files, does not
let name =
String.capitalize_ascii(Filename.basename(chop_extensions file)) in
let kind =
- if Filename.check_suffix file ".cmx" then begin
+ if Filename.check_suffix file ".cmi" then
+ PM_intf
+ else begin
let (info, crc) = Compilenv.read_unit_info file in
if info.ui_name <> name
then raise(Error(Illegal_renaming(name, file, info.ui_name)));
Asmlink.check_consistency file info crc;
Compilenv.cache_unit_info info;
PM_impl info
- end else
- PM_intf in
+ end in
{ pm_file = file; pm_name = name; pm_kind = kind }
)
arity : int;
params : Ident.t list;
body : ulambda;
- dbg : Debuginfo.t
+ dbg : Debuginfo.t;
+ env : Ident.t option;
}
and ulambda_switch =
params : Ident.t list;
body : ulambda;
dbg : Debuginfo.t;
+ env : Ident.t option;
}
and ulambda_switch =
| Pfield _ -> 1
| Psetfield(_f, isptr, init) ->
begin match init with
- | Initialization -> 1 (* never causes a write barrier hit *)
- | Assignment ->
+ | Root_initialization -> 1 (* never causes a write barrier hit *)
+ | Assignment | Heap_initialization ->
match isptr with
| Pointer -> 4
| Immediate -> 1
with Exit ->
false
+let is_pure_prim p =
+ let open Semantics_of_primitives in
+ match Semantics_of_primitives.for_primitive p with
+ | (No_effects | Only_generative_effects), _ -> true
+ | Arbitrary_effects, _ -> false
+
(* Check if a clambda term is ``pure'',
that is without side-effects *and* not containing function definitions *)
let rec is_pure_clambda = function
Uvar _ -> true
| Uconst _ -> true
- | Uprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ |
- Pccall _ | Praise _ | Poffsetref _ | Pbytessetu | Pbytessets |
- Parraysetu _ | Parraysets _ | Pbigarrayset _), _, _) -> false
- | Uprim(_, args, _) -> List.for_all is_pure_clambda args
+ | Uprim(p, args, _) -> is_pure_prim p && List.for_all is_pure_clambda args
| _ -> false
(* Simplify primitive operations on known arguments *)
let no_effects = function
| Uclosure _ -> true
- | u -> is_simple_argument u
+ | u -> is_pure_clambda u
let rec bind_params_rec loc fpc subst params args body =
match (params, args) with
let rec is_pure = function
Lvar _ -> true
| Lconst _ -> true
- | Lprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ |
- Pccall _ | Praise _ | Poffsetref _ | Pbytessetu | Pbytessets |
- Parraysetu _ | Parraysets _ | Pbigarrayset _), _,_) -> false
- | Lprim(_, args,_) -> List.for_all is_pure args
+ | Lprim(p, args,_) -> is_pure_prim p && List.for_all is_pure args
| Levent(lam, _ev) -> is_pure lam
| _ -> false
| 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]
+ (* We convert [f a] to [let a' = a in let f' = f in fun b c -> f' a' b c]
when fun_arity > nargs *)
| Lapply{ap_func = funct; ap_args = args; ap_loc = loc;
ap_inlined = attribute} ->
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, _) as fapprox)), uargs)
when nargs < fundesc.fun_arity ->
let first_args = List.map (fun arg ->
(Ident.create "arg", arg) ) uargs in
(List.map (fun (arg1, _arg2) -> Lvar arg1) first_args)
@ (List.map (fun arg -> Lvar arg ) final_args)
in
+ let funct_var = Ident.create "funct" in
+ let fenv = Tbl.add funct_var fapprox fenv in
let (new_fun, approx) = close fenv cenv
(Lfunction{
kind = Curried;
params = final_args;
body = Lapply{ap_should_be_tailcall=false;
ap_loc=loc;
- ap_func=funct;
+ ap_func=(Lvar funct_var);
ap_args=internal_args;
ap_inlined=Default_inline;
ap_specialised=Default_specialise};
loc;
attr = default_function_attribute})
in
- let new_fun = iter first_args new_fun in
+ let new_fun =
+ iter first_args
+ (Ulet (Immutable, Pgenval, funct_var, ufunct, new_fun))
+ in
warning_if_forced_inline ~loc ~attribute "Partial application";
(new_fun, approx)
| ((ufunct, Value_closure(fundesc, _approx_res)), uargs)
when fundesc.fun_arity > 0 && nargs > fundesc.fun_arity ->
- let (first_args, rem_args) = split_list fundesc.fun_arity uargs in
+ let args = List.map (fun arg -> Ident.create "arg", arg) uargs in
+ let (first_args, rem_args) = split_list fundesc.fun_arity args in
+ let first_args = List.map (fun (id, _) -> Uvar id) first_args in
+ let rem_args = List.map (fun (id, _) -> Uvar id) rem_args in
let dbg = Debuginfo.from_location loc in
warning_if_forced_inline ~loc ~attribute "Over-application";
- (Ugeneric_apply(direct_apply ~loc ~attribute
- fundesc funct ufunct first_args,
- rem_args, dbg),
- Value_unknown)
+ let body =
+ Ugeneric_apply(direct_apply ~loc ~attribute
+ fundesc funct ufunct first_args,
+ rem_args, dbg)
+ in
+ let result =
+ List.fold_left (fun body (id, defining_expr) ->
+ Ulet (Immutable, Pgenval, id, defining_expr, body))
+ body
+ args
+ in
+ result, Value_unknown
| ((ufunct, _), uargs) ->
let dbg = Debuginfo.from_location loc in
warning_if_forced_inline ~loc ~attribute "Unknown function";
(function
| (id, Lfunction{kind; params; body; attr; loc}) ->
Simplif.split_default_wrapper ~id ~kind ~params
- ~body ~attr ~wrapper_attr:attr ~loc ()
+ ~body ~attr ~loc
| _ -> assert false
)
fun_defs)
in
let inline_attribute = match fun_defs with
- | [_, Lfunction{attr = { inline }}] -> inline
+ | [_, Lfunction{attr = { inline; }}] -> inline
| _ -> Default_inline (* recursive functions can't be inlined *)
in
-
(* Update and check nesting depth *)
incr function_nesting_depth;
let initially_closed =
params = fun_params;
body = ubody;
dbg;
+ env = Some env_param;
}
in
(* give more chance of function with default parameters (i.e.
| Raise_withtrace
| Raise_notrace
+type rec_flag = Nonrecursive | Recursive
+
type memory_chunk =
Byte_unsigned
| Byte_signed
| Double_u
and operation =
- Capply of machtype * Debuginfo.t
- | Cextcall of string * machtype * bool * Debuginfo.t * label option
+ Capply of machtype
+ | Cextcall of string * machtype * bool * 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 of Debuginfo.t
+ | Cload of memory_chunk * Asttypes.mutable_flag
+ | Calloc
| Cstore of memory_chunk * Lambda.initialization_or_assignment
| Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi
| Cand | Cor | Cxor | Clsl | Clsr | Casr
| Caddf | Csubf | Cmulf | Cdivf
| Cfloatofint | Cintoffloat
| Ccmpf of comparison
- | Craise of raise_kind * Debuginfo.t
- | Ccheckbound of Debuginfo.t
+ | Craise of raise_kind
+ | Ccheckbound
type expression =
Cconst_int of int
| Clet of Ident.t * expression * expression
| Cassign of Ident.t * expression
| Ctuple of expression list
- | Cop of operation * expression list
+ | Cop of operation * expression list * Debuginfo.t
| Csequence of expression * expression
| Cifthenelse of expression * expression * expression
- | Cswitch of expression * int array * expression array
+ | Cswitch of expression * int array * expression array * Debuginfo.t
| Cloop of expression
- | Ccatch of int * Ident.t list * expression * expression
+ | Ccatch of rec_flag * (int * Ident.t list * expression) list * expression
| Cexit of int * expression list
| Ctrywith of expression * Ident.t * expression
Cfunction of fundecl
| Cdata of data_item list
+let ccatch (i, ids, e1, e2)=
+ Ccatch(Nonrecursive, [i, ids, e2], e1)
+
let reset () =
label_counter := 99
| Raise_withtrace
| Raise_notrace
+type rec_flag = Nonrecursive | Recursive
+
type memory_chunk =
Byte_unsigned
| Byte_signed
| Double_u (* word-aligned 64-bit float *)
and operation =
- Capply of machtype * Debuginfo.t
- | Cextcall of string * machtype * bool * Debuginfo.t * label option
- | Cload of memory_chunk
- | Calloc of Debuginfo.t
+ Capply of machtype
+ | Cextcall of string * machtype * bool * label option
+ | Cload of memory_chunk * Asttypes.mutable_flag
+ | Calloc
| Cstore of memory_chunk * Lambda.initialization_or_assignment
| Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi
| Cand | Cor | Cxor | Clsl | Clsr | Casr
| Caddf | Csubf | Cmulf | Cdivf
| Cfloatofint | Cintoffloat
| Ccmpf of comparison
- | Craise of raise_kind * Debuginfo.t
- | Ccheckbound of Debuginfo.t
+ | Craise of raise_kind
+ | Ccheckbound
+(** Not all cmm expressions currently have [Debuginfo.t] values attached to
+ them. The ones that do are those that are likely to generate code that
+ can fairly robustly be mapped back to a source location. In the future
+ it might be the case that more [Debuginfo.t] annotations are desirable. *)
and expression =
Cconst_int of int
| Cconst_natint of nativeint
| Clet of Ident.t * expression * expression
| Cassign of Ident.t * expression
| Ctuple of expression list
- | Cop of operation * expression list
+ | Cop of operation * expression list * Debuginfo.t
| Csequence of expression * expression
| Cifthenelse of expression * expression * expression
- | Cswitch of expression * int array * expression array
+ | Cswitch of expression * int array * expression array * Debuginfo.t
| Cloop of expression
- | Ccatch of int * Ident.t list * expression * expression
+ | Ccatch of rec_flag * (int * Ident.t list * expression) list * expression
| Cexit of int * expression list
| Ctrywith of expression * Ident.t * expression
Cfunction of fundecl
| Cdata of data_item list
+val ccatch : int * Ident.t list * expression * expression -> expression
+
val reset : unit -> unit
open Cmm
open Cmx_format
+(* Environments used for translation to Cmm. *)
+
+type boxed_number =
+ | Boxed_float of Debuginfo.t
+ | Boxed_integer of boxed_integer * Debuginfo.t
+
+type env = {
+ unboxed_ids : (Ident.t * boxed_number) Ident.tbl;
+ environment_param : Ident.t option;
+}
+
+let empty_env =
+ {
+ unboxed_ids =Ident.empty;
+ environment_param = None;
+ }
+
+let create_env ~environment_param =
+ { unboxed_ids = Ident.empty;
+ environment_param;
+ }
+
+let is_unboxed_id id env =
+ try Some (Ident.find_same id env.unboxed_ids)
+ with Not_found -> None
+
+let add_unboxed_id id unboxed_id bn env =
+ { env with
+ unboxed_ids = Ident.add id (unboxed_id, bn) env.unboxed_ids;
+ }
+
(* Local binding of complex expressions *)
let bind name arg fn =
let bind_load name arg fn =
match arg with
- | Cop(Cload _, [Cvar _]) -> fn arg
+ | Cop(Cload _, [Cvar _], _) -> fn arg
| _ -> bind name arg fn
let bind_nonvar name arg fn =
let infix_header ofs = block_header Obj.infix_tag ofs
let float_header = block_header Obj.double_tag (size_float / size_addr)
let floatarray_header len =
- block_header Obj.double_array_tag (len * size_float / size_addr)
+ (* Zero-sized float arrays have tag zero for consistency with
+ [caml_alloc_float_array]. *)
+ assert (len >= 0);
+ if len = 0 then block_header 0 0
+ else block_header Obj.double_array_tag (len * size_float / size_addr)
let string_header len =
block_header Obj.string_tag ((len + size_addr) / size_addr)
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 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)
+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 *)
let cint_const n =
Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n)
-let add_no_overflow n x c =
+let add_no_overflow n x c dbg =
let d = n + x in
- if d = 0 then c else Cop(Caddi, [c; Cconst_int d])
+ if d = 0 then c else Cop(Caddi, [c; Cconst_int d], dbg)
-let rec add_const c n =
+let rec add_const c n dbg =
if n = 0 then c
else match c with
| Cconst_int x when no_overflow_add x n -> Cconst_int (x + n)
- | Cop(Caddi, [Cconst_int x; c])
+ | Cop(Caddi, [Cconst_int x; c], _)
when no_overflow_add n x ->
- add_no_overflow n x c
- | Cop(Caddi, [c; Cconst_int x])
+ add_no_overflow n x c dbg
+ | Cop(Caddi, [c; Cconst_int x], _)
when no_overflow_add n x ->
- add_no_overflow n x c
- | Cop(Csubi, [Cconst_int x; c]) when no_overflow_add n x ->
- Cop(Csubi, [Cconst_int (n + x); c])
- | Cop(Csubi, [c; Cconst_int x]) when no_overflow_sub n x ->
- add_const c (n - x)
- | c -> Cop(Caddi, [c; Cconst_int n])
+ add_no_overflow n x c dbg
+ | Cop(Csubi, [Cconst_int x; c], _) when no_overflow_add n x ->
+ Cop(Csubi, [Cconst_int (n + x); c], dbg)
+ | Cop(Csubi, [c; Cconst_int x], _) when no_overflow_sub n x ->
+ add_const c (n - x) dbg
+ | c -> Cop(Caddi, [c; Cconst_int n], dbg)
-let incr_int c = add_const c 1
-let decr_int c = add_const c (-1)
+let incr_int c dbg = add_const c 1 dbg
+let decr_int c dbg = add_const c (-1) dbg
-let rec add_int c1 c2 =
+let rec add_int c1 c2 dbg =
match (c1, c2) with
| (Cconst_int n, c) | (c, Cconst_int n) ->
- add_const c n
- | (Cop(Caddi, [c1; Cconst_int n1]), c2) ->
- add_const (add_int c1 c2) n1
- | (c1, Cop(Caddi, [c2; Cconst_int n2])) ->
- add_const (add_int c1 c2) n2
+ add_const c n dbg
+ | (Cop(Caddi, [c1; Cconst_int n1], _), c2) ->
+ add_const (add_int c1 c2 dbg) n1 dbg
+ | (c1, Cop(Caddi, [c2; Cconst_int n2], _)) ->
+ add_const (add_int c1 c2 dbg) n2 dbg
| (_, _) ->
- Cop(Caddi, [c1; c2])
+ Cop(Caddi, [c1; c2], dbg)
-let rec sub_int c1 c2 =
+let rec sub_int c1 c2 dbg =
match (c1, c2) with
| (c1, Cconst_int n2) when n2 <> min_int ->
- add_const c1 (-n2)
- | (c1, Cop(Caddi, [c2; Cconst_int n2])) when n2 <> min_int ->
- add_const (sub_int c1 c2) (-n2)
- | (Cop(Caddi, [c1; Cconst_int n1]), c2) ->
- add_const (sub_int c1 c2) n1
+ add_const c1 (-n2) dbg
+ | (c1, Cop(Caddi, [c2; Cconst_int n2], _)) when n2 <> min_int ->
+ add_const (sub_int c1 c2 dbg) (-n2) dbg
+ | (Cop(Caddi, [c1; Cconst_int n1], _), c2) ->
+ add_const (sub_int c1 c2 dbg) n1 dbg
| (c1, c2) ->
- Cop(Csubi, [c1; c2])
+ Cop(Csubi, [c1; c2], dbg)
-let rec lsl_int c1 c2 =
+let rec lsl_int c1 c2 dbg =
match (c1, c2) with
- | (Cop(Clsl, [c; Cconst_int n1]), Cconst_int n2)
+ | (Cop(Clsl, [c; Cconst_int n1], _), Cconst_int n2)
when n1 > 0 && n2 > 0 && n1 + n2 < size_int * 8 ->
- Cop(Clsl, [c; Cconst_int (n1 + n2)])
- | (Cop(Caddi, [c1; Cconst_int n1]), Cconst_int n2)
+ Cop(Clsl, [c; Cconst_int (n1 + n2)], dbg)
+ | (Cop(Caddi, [c1; Cconst_int n1], _), Cconst_int n2)
when no_overflow_lsl n1 n2 ->
- add_const (lsl_int c1 c2) (n1 lsl n2)
+ add_const (lsl_int c1 c2 dbg) (n1 lsl n2) dbg
| (_, _) ->
- Cop(Clsl, [c1; c2])
+ Cop(Clsl, [c1; c2], dbg)
let is_power2 n = n = 1 lsl Misc.log2 n
-and mult_power2 c n = lsl_int c (Cconst_int (Misc.log2 n))
+and mult_power2 c n dbg = lsl_int c (Cconst_int (Misc.log2 n)) dbg
-let rec mul_int c1 c2 =
+let rec mul_int c1 c2 dbg =
match (c1, c2) with
- | (_, Cconst_int 0) | (Cconst_int 0, _) ->
- Cconst_int 0
+ | (c, Cconst_int 0) | (Cconst_int 0, c) -> Csequence (c, Cconst_int 0)
| (c, Cconst_int 1) | (Cconst_int 1, c) ->
c
| (c, Cconst_int(-1)) | (Cconst_int(-1), c) ->
- sub_int (Cconst_int 0) c
- | (c, Cconst_int n) when is_power2 n -> mult_power2 c n
- | (Cconst_int n, c) when is_power2 n -> mult_power2 c n
- | (Cop(Caddi, [c; Cconst_int n]), Cconst_int k) |
- (Cconst_int k, Cop(Caddi, [c; Cconst_int n]))
+ sub_int (Cconst_int 0) c dbg
+ | (c, Cconst_int n) when is_power2 n -> mult_power2 c n dbg
+ | (Cconst_int n, c) when is_power2 n -> mult_power2 c n dbg
+ | (Cop(Caddi, [c; Cconst_int n], _), Cconst_int k) |
+ (Cconst_int k, Cop(Caddi, [c; Cconst_int n], _))
when no_overflow_mul n k ->
- add_const (mul_int c (Cconst_int k)) (n * k)
+ add_const (mul_int c (Cconst_int k) dbg) (n * k) dbg
| (c1, c2) ->
- Cop(Cmuli, [c1; c2])
+ Cop(Cmuli, [c1; c2], dbg)
let ignore_low_bit_int = function
- Cop(Caddi, [(Cop(Clsl, [_; Cconst_int n]) as c); Cconst_int 1]) when n > 0
+ Cop(Caddi, [(Cop(Clsl, [_; Cconst_int n], _) as c); Cconst_int 1], _)
+ when n > 0
-> c
- | Cop(Cor, [c; Cconst_int 1]) -> c
+ | Cop(Cor, [c; Cconst_int 1], _) -> c
| c -> c
-let lsr_int c1 c2 =
+let lsr_int c1 c2 dbg =
match c2 with
Cconst_int 0 ->
c1
| Cconst_int n when n > 0 ->
- Cop(Clsr, [ignore_low_bit_int c1; c2])
+ Cop(Clsr, [ignore_low_bit_int c1; c2], dbg)
| _ ->
- Cop(Clsr, [c1; c2])
+ Cop(Clsr, [c1; c2], dbg)
-let asr_int c1 c2 =
+let asr_int c1 c2 dbg =
match c2 with
Cconst_int 0 ->
c1
| Cconst_int n when n > 0 ->
- Cop(Casr, [ignore_low_bit_int c1; c2])
+ Cop(Casr, [ignore_low_bit_int c1; c2], dbg)
| _ ->
- Cop(Casr, [c1; c2])
+ Cop(Casr, [c1; c2], dbg)
-let tag_int = function
+let tag_int i dbg =
+ match i with
Cconst_int n ->
int_const n
- | Cop(Casr, [c; Cconst_int n]) when n > 0 ->
- Cop(Cor, [asr_int c (Cconst_int (n - 1)); Cconst_int 1])
+ | Cop(Casr, [c; Cconst_int n], _) when n > 0 ->
+ Cop(Cor, [asr_int c (Cconst_int (n - 1)) dbg; Cconst_int 1], dbg)
| c ->
- incr_int (lsl_int c (Cconst_int 1))
+ incr_int (lsl_int c (Cconst_int 1) dbg) dbg
-let force_tag_int = function
+let force_tag_int i dbg =
+ match i with
Cconst_int n ->
int_const n
- | Cop(Casr, [c; Cconst_int n]) when n > 0 ->
- Cop(Cor, [asr_int c (Cconst_int (n - 1)); Cconst_int 1])
+ | Cop(Casr, [c; Cconst_int n], dbg) when n > 0 ->
+ Cop(Cor, [asr_int c (Cconst_int (n - 1)) dbg; Cconst_int 1], dbg)
| c ->
- Cop(Cor, [lsl_int c (Cconst_int 1); Cconst_int 1])
+ Cop(Cor, [lsl_int c (Cconst_int 1) dbg; Cconst_int 1], dbg)
-let untag_int = function
+let untag_int i dbg =
+ match i with
Cconst_int n -> Cconst_int(n asr 1)
- | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) -> c
- | Cop(Cor, [Cop(Casr, [c; Cconst_int n]); Cconst_int 1])
+ | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1], _); Cconst_int 1], _) -> c
+ | Cop(Cor, [Cop(Casr, [c; Cconst_int n], _); Cconst_int 1], _)
when n > 0 && n < size_int * 8 ->
- Cop(Casr, [c; Cconst_int (n+1)])
- | Cop(Cor, [Cop(Clsr, [c; Cconst_int n]); Cconst_int 1])
+ Cop(Casr, [c; Cconst_int (n+1)], dbg)
+ | Cop(Cor, [Cop(Clsr, [c; Cconst_int n], _); Cconst_int 1], _)
when n > 0 && n < size_int * 8 ->
- Cop(Clsr, [c; Cconst_int (n+1)])
- | Cop(Cor, [c; Cconst_int 1]) -> Cop(Casr, [c; Cconst_int 1])
- | c -> Cop(Casr, [c; Cconst_int 1])
+ Cop(Clsr, [c; Cconst_int (n+1)], dbg)
+ | Cop(Cor, [c; Cconst_int 1], _) -> Cop(Casr, [c; Cconst_int 1], dbg)
+ | c -> Cop(Casr, [c; Cconst_int 1], dbg)
let if_then_else (cond, ifso, ifnot) =
match cond with
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]))
+ [(Cconst_symbol "caml_backtrace_pos"); Cconst_int 0], dbg),
+ Cop(Craise Raise_withtrace,[exc], dbg))
let raise_symbol dbg symb =
raise_regular dbg (Cconst_symbol symb)
Csequence(c1, raise_symbol dbg "caml_exn_Division_by_zero")
| (c1, Cconst_int 1) ->
c1
- | (Cconst_int 0 as c1, c2) ->
- Csequence(c2, c1)
| (Cconst_int n1, Cconst_int n2) ->
Cconst_int (n1 / n2)
| (c1, Cconst_int n) when n <> min_int ->
res = shift-right-signed(c1 + t, l)
*)
Cop(Casr, [bind "dividend" c1 (fun c1 ->
- let t = asr_int c1 (Cconst_int (l - 1)) in
- let t = lsr_int t (Cconst_int (Nativeint.size - l)) in
- add_int c1 t);
- Cconst_int l])
+ let t = asr_int c1 (Cconst_int (l - 1)) dbg in
+ let t = lsr_int t (Cconst_int (Nativeint.size - l)) dbg in
+ add_int c1 t dbg);
+ Cconst_int l], dbg)
else if n < 0 then
- sub_int (Cconst_int 0) (div_int c1 (Cconst_int (-n)) is_safe dbg)
+ sub_int (Cconst_int 0) (div_int c1 (Cconst_int (-n)) is_safe dbg) dbg
else begin
let (m, p) = divimm_parameters (Nativeint.of_int n) in
(* Algorithm:
res = t + sign-bit(c1)
*)
bind "dividend" c1 (fun c1 ->
- let t = Cop(Cmulhi, [c1; Cconst_natint m]) in
- let t = if m < 0n then Cop(Caddi, [t; c1]) else t in
- 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))))
+ let t = Cop(Cmulhi, [c1; Cconst_natint m], dbg) in
+ let t = if m < 0n then Cop(Caddi, [t; c1], dbg) else t in
+ let t = if p > 0 then Cop(Casr, [t; Cconst_int p], dbg) else t in
+ add_int t (lsr_int c1 (Cconst_int (Nativeint.size - 1)) dbg) dbg)
end
| (c1, c2) when !Clflags.fast || is_safe = Lambda.Unsafe ->
- Cop(Cdivi, [c1; c2])
+ Cop(Cdivi, [c1; c2], dbg)
| (c1, c2) ->
bind "divisor" c2 (fun c2 ->
- Cifthenelse(c2,
- Cop(Cdivi, [c1; c2]),
- raise_symbol dbg "caml_exn_Division_by_zero"))
+ bind "dividend" c1 (fun c1 ->
+ Cifthenelse(c2,
+ Cop(Cdivi, [c1; c2], dbg),
+ raise_symbol dbg "caml_exn_Division_by_zero")))
let mod_int c1 c2 is_safe dbg =
match (c1, c2) with
Csequence(c1, raise_symbol dbg "caml_exn_Division_by_zero")
| (c1, Cconst_int (1 | (-1))) ->
Csequence(c1, Cconst_int 0)
- | (Cconst_int 0, c2) ->
- Csequence(c2, Cconst_int 0)
| (Cconst_int n1, Cconst_int n2) ->
Cconst_int (n1 mod n2)
| (c1, (Cconst_int n as c2)) when n <> min_int ->
res = c1 - t
*)
bind "dividend" c1 (fun c1 ->
- let t = asr_int c1 (Cconst_int (l - 1)) in
- let t = lsr_int t (Cconst_int (Nativeint.size - l)) in
- let t = add_int c1 t in
- let t = Cop(Cand, [t; Cconst_int (-n)]) in
- sub_int c1 t)
+ let t = asr_int c1 (Cconst_int (l - 1)) dbg in
+ let t = lsr_int t (Cconst_int (Nativeint.size - l)) dbg in
+ let t = add_int c1 t dbg in
+ let t = Cop(Cand, [t; Cconst_int (-n)], dbg) in
+ sub_int c1 t dbg)
else
bind "dividend" c1 (fun c1 ->
- sub_int c1 (mul_int (div_int c1 c2 is_safe dbg) c2))
+ sub_int c1 (mul_int (div_int c1 c2 is_safe dbg) c2 dbg) dbg)
| (c1, c2) when !Clflags.fast || is_safe = Lambda.Unsafe ->
(* Flambda already generates that test *)
- Cop(Cmodi, [c1; c2])
+ Cop(Cmodi, [c1; c2], dbg)
| (c1, c2) ->
bind "divisor" c2 (fun c2 ->
- Cifthenelse(c2,
- Cop(Cmodi, [c1; c2]),
- raise_symbol dbg "caml_exn_Division_by_zero"))
+ bind "dividend" c1 (fun c1 ->
+ Cifthenelse(c2,
+ Cop(Cmodi, [c1; c2], dbg),
+ 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). *)
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)
+ then Cifthenelse(Cop(Ccmpi Cne, [c2; Cconst_int(-1)], dbg), c, mkm1 c1 dbg)
else c))
let safe_div_bi is_safe =
- safe_divmod_bi div_int is_safe (fun c1 -> Cop(Csubi, [Cconst_int 0; c1]))
+ safe_divmod_bi div_int is_safe
+ (fun c1 dbg -> Cop(Csubi, [Cconst_int 0; c1], dbg))
let safe_mod_bi is_safe =
- safe_divmod_bi mod_int is_safe (fun _ -> Cconst_int 0)
+ safe_divmod_bi mod_int is_safe (fun _ _ -> Cconst_int 0)
(* Bool *)
-let test_bool = function
- Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) -> c
+let test_bool dbg cmm =
+ match cmm with
+ | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1], _); Cconst_int 1], _) -> c
| Cconst_int n ->
if n = 1 then
Cconst_int 0
else
Cconst_int 1
- | c -> Cop(Ccmpi Cne, [c; Cconst_int 1])
+ | c -> Cop(Ccmpi Cne, [c; Cconst_int 1], dbg)
(* Float *)
-let box_float dbg c = Cop(Calloc dbg, [alloc_float_header dbg; c])
+let box_float dbg c = Cop(Calloc, [alloc_float_header dbg; c], dbg)
-let rec unbox_float = function
- Cop(Calloc _, [_header; c]) -> c
- | Clet(id, exp, body) -> Clet(id, exp, unbox_float body)
+let map_ccatch f rec_flag handlers body =
+ let handlers = List.map
+ (fun (n, ids, handler) -> (n, ids, f handler))
+ handlers in
+ Ccatch(rec_flag, handlers, f body)
+
+let rec unbox_float dbg cmm =
+ match cmm with
+ | Cop(Calloc, [_header; c], _) -> c
+ | Clet(id, exp, body) -> Clet(id, exp, unbox_float dbg body)
| Cifthenelse(cond, e1, e2) ->
- Cifthenelse(cond, unbox_float e1, unbox_float e2)
- | Csequence(e1, e2) -> Csequence(e1, unbox_float e2)
- | Cswitch(e, tbl, el) -> Cswitch(e, tbl, Array.map unbox_float el)
- | Ccatch(n, ids, e1, e2) -> Ccatch(n, ids, unbox_float e1, unbox_float e2)
- | Ctrywith(e1, id, e2) -> Ctrywith(unbox_float e1, id, unbox_float e2)
- | c -> Cop(Cload Double_u, [c])
+ Cifthenelse(cond, unbox_float dbg e1, unbox_float dbg e2)
+ | Csequence(e1, e2) -> Csequence(e1, unbox_float dbg e2)
+ | Cswitch(e, tbl, el, dbg) ->
+ Cswitch(e, tbl, Array.map (unbox_float dbg) el, dbg)
+ | Ccatch(rec_flag, handlers, body) ->
+ map_ccatch (unbox_float dbg) rec_flag handlers body
+ | Ctrywith(e1, id, e2) -> Ctrywith(unbox_float dbg e1, id, unbox_float dbg e2)
+ | c -> Cop(Cload (Double_u, Immutable), [c], dbg)
(* Complex *)
let box_complex dbg c_re c_im =
- Cop(Calloc dbg, [alloc_floatarray_header 2 dbg; c_re; c_im])
+ Cop(Calloc, [alloc_floatarray_header 2 dbg; c_re; c_im], dbg)
-let complex_re c = Cop(Cload Double_u, [c])
-let complex_im c = Cop(Cload Double_u,
- [Cop(Cadda, [c; Cconst_int size_float])])
+let complex_re c dbg = Cop(Cload (Double_u, Immutable), [c], dbg)
+let complex_im c dbg = Cop(Cload (Double_u, Immutable),
+ [Cop(Cadda, [c; Cconst_int size_float], dbg)], dbg)
(* Unit *)
Csequence(c1, remove_unit c2)
| Cifthenelse(cond, ifso, ifnot) ->
Cifthenelse(cond, remove_unit ifso, remove_unit ifnot)
- | Cswitch(sel, index, cases) ->
- Cswitch(sel, index, Array.map remove_unit cases)
- | Ccatch(io, ids, body, handler) ->
- Ccatch(io, ids, remove_unit body, remove_unit handler)
+ | Cswitch(sel, index, cases, dbg) ->
+ Cswitch(sel, index, Array.map remove_unit cases, dbg)
+ | Ccatch(rec_flag, handlers, body) ->
+ map_ccatch remove_unit rec_flag handlers body
| Ctrywith(body, exn, handler) ->
Ctrywith(remove_unit body, exn, remove_unit handler)
| Clet(id, c1, c2) ->
Clet(id, c1, remove_unit c2)
- | Cop(Capply (_mty, dbg), args) ->
- Cop(Capply (typ_void, dbg), args)
- | Cop(Cextcall(proc, _mty, alloc, dbg, label_after), args) ->
- Cop(Cextcall(proc, typ_void, alloc, dbg, label_after), args)
+ | Cop(Capply _mty, args, dbg) ->
+ Cop(Capply typ_void, args, dbg)
+ | Cop(Cextcall(proc, _mty, alloc, label_after), args, dbg) ->
+ Cop(Cextcall(proc, typ_void, alloc, label_after), args, dbg)
| Cexit (_,_) as c -> c
| Ctuple [] as c -> c
| c -> Csequence(c, Ctuple [])
(* Access to block fields *)
-let field_address ptr n =
+let field_address ptr n dbg =
if n = 0
then ptr
- else Cop(Cadda, [ptr; Cconst_int(n * size_addr)])
+ else Cop(Cadda, [ptr; Cconst_int(n * size_addr)], dbg)
+
+let get_field env ptr n dbg =
+ let mut =
+ match env.environment_param with
+ | None -> Mutable
+ | Some environment_param ->
+ match ptr with
+ | Cvar ptr ->
+ (* Loads from the current function's closure are immutable. *)
+ if Ident.same environment_param ptr then Immutable
+ else Mutable
+ | _ -> Mutable
+ in
+ Cop(Cload (Word_val, mut), [field_address ptr n dbg], dbg)
+let set_field ptr n newval init dbg =
+ Cop(Cstore (Word_val, init), [field_address ptr n dbg; newval], dbg)
-let get_field ptr n =
- Cop(Cload Word_val, [field_address ptr n])
+let non_profinfo_mask = (1 lsl (64 - Config.profinfo_width)) - 1
-let set_field ptr n newval init =
- Cop(Cstore (Word_val, init), [field_address ptr n; newval])
+let get_header ptr dbg =
+ (* We cannot deem this as [Immutable] due to the presence of [Obj.truncate]
+ and [Obj.set_tag]. *)
+ Cop(Cload (Word_int, Mutable),
+ [Cop(Cadda, [ptr; Cconst_int(-size_int)], dbg)], dbg)
-let header ptr =
- 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;
- ])
+let get_header_without_profinfo ptr dbg =
+ if Config.profinfo then
+ Cop(Cand, [get_header ptr dbg; Cconst_int non_profinfo_mask], dbg)
else
- Cop(Cload Word_int, [Cop(Cadda, [ptr; Cconst_int(-size_int)])])
+ get_header ptr dbg
let tag_offset =
if big_endian then -1 else -size_int
-let get_tag ptr =
+let get_tag ptr dbg =
if Proc.word_addressed then (* If byte loads are slow *)
- Cop(Cand, [header ptr; Cconst_int 255])
+ Cop(Cand, [get_header ptr dbg; Cconst_int 255], dbg)
else (* If byte loads are efficient *)
- Cop(Cload Byte_unsigned,
- [Cop(Cadda, [ptr; Cconst_int(tag_offset)])])
+ Cop(Cload (Byte_unsigned, Mutable), (* Same comment as [get_header] above *)
+ [Cop(Cadda, [ptr; Cconst_int(tag_offset)], dbg)], dbg)
-let get_size ptr =
- Cop(Clsr, [header ptr; Cconst_int 10])
+let get_size ptr dbg =
+ Cop(Clsr, [get_header_without_profinfo ptr dbg; Cconst_int 10], dbg)
(* Array indexing *)
let wordsize_shift = 9
let numfloat_shift = 9 + log2_size_float - log2_size_addr
-let is_addr_array_hdr hdr =
- Cop(Ccmpi Cne, [Cop(Cand, [hdr; Cconst_int 255]); floatarray_tag])
+let is_addr_array_hdr hdr dbg =
+ Cop(Ccmpi Cne, [Cop(Cand, [hdr; Cconst_int 255], dbg); floatarray_tag], dbg)
-let is_addr_array_ptr ptr =
- Cop(Ccmpi Cne, [get_tag ptr; floatarray_tag])
+let is_addr_array_ptr ptr dbg =
+ Cop(Ccmpi Cne, [get_tag ptr dbg; floatarray_tag], dbg)
-let addr_array_length hdr = Cop(Clsr, [hdr; Cconst_int wordsize_shift])
-let float_array_length hdr = Cop(Clsr, [hdr; Cconst_int numfloat_shift])
+let addr_array_length hdr dbg =
+ Cop(Clsr, [hdr; Cconst_int wordsize_shift], dbg)
+let float_array_length hdr dbg =
+ Cop(Clsr, [hdr; Cconst_int numfloat_shift], dbg)
-let lsl_const c n =
+let lsl_const c n dbg =
if n = 0 then c
- else Cop(Clsl, [c; Cconst_int n])
+ else Cop(Clsl, [c; Cconst_int n], dbg)
(* Produces a pointer to the element of the array [ptr] on the position [ofs]
with the given element [log2size] log2 element size. [ofs] is given as a
into the heap. If we know the pointer is outside the heap
(this is the case for bigarray indexing), we give type Int instead. *)
-let array_indexing ?typ log2size ptr ofs =
+let array_indexing ?typ log2size ptr ofs dbg =
let add =
match typ with
| None | Some Addr -> Cadda
| Some Int -> Caddi
| _ -> assert false in
match ofs with
- Cconst_int n ->
+ | Cconst_int n ->
let i = n asr 1 in
- if i = 0 then ptr else Cop(add, [ptr; Cconst_int(i lsl log2size)])
- | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) ->
- Cop(add, [ptr; lsl_const c log2size])
- | Cop(Caddi, [c; Cconst_int n]) when log2size = 0 ->
- Cop(add, [Cop(add, [ptr; untag_int c]); Cconst_int (n asr 1)])
- | Cop(Caddi, [c; Cconst_int n]) ->
- Cop(add, [Cop(add, [ptr; lsl_const c (log2size - 1)]);
- Cconst_int((n-1) lsl (log2size - 1))])
+ if i = 0 then ptr else Cop(add, [ptr; Cconst_int(i lsl log2size)], dbg)
+ | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1], _); Cconst_int 1], _) ->
+ Cop(add, [ptr; lsl_const c log2size dbg], dbg)
+ | Cop(Caddi, [c; Cconst_int n], _) when log2size = 0 ->
+ Cop(add, [Cop(add, [ptr; untag_int c dbg], dbg); Cconst_int (n asr 1)],
+ dbg)
+ | Cop(Caddi, [c; Cconst_int n], _) ->
+ Cop(add, [Cop(add, [ptr; lsl_const c (log2size - 1) dbg], dbg);
+ Cconst_int((n-1) lsl (log2size - 1))], dbg)
| _ when log2size = 0 ->
- Cop(add, [ptr; untag_int ofs])
+ Cop(add, [ptr; untag_int ofs dbg], dbg)
| _ ->
- Cop(add, [Cop(add, [ptr; lsl_const ofs (log2size - 1)]);
- Cconst_int((-1) lsl (log2size - 1))])
-
-let addr_array_ref arr ofs =
- Cop(Cload Word_val, [array_indexing log2_size_addr arr ofs])
-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])
+ Cop(add, [Cop(add, [ptr; lsl_const ofs (log2size - 1) dbg], dbg);
+ Cconst_int((-1) lsl (log2size - 1))], dbg)
+
+let addr_array_ref arr ofs dbg =
+ Cop(Cload (Word_val, Mutable),
+ [array_indexing log2_size_addr arr ofs dbg], dbg)
+let int_array_ref arr ofs dbg =
+ Cop(Cload (Word_int, Mutable),
+ [array_indexing log2_size_addr arr ofs dbg], dbg)
+let unboxed_float_array_ref arr ofs dbg =
+ Cop(Cload (Double_u, Mutable),
+ [array_indexing log2_size_float arr ofs dbg], dbg)
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, None),
- [array_indexing log2_size_addr arr ofs; newval])
-let int_array_set arr ofs newval =
+ box_float dbg (unboxed_float_array_ref arr ofs dbg)
+
+let addr_array_set arr ofs newval dbg =
+ Cop(Cextcall("caml_modify", typ_void, false, None),
+ [array_indexing log2_size_addr arr ofs dbg; newval], dbg)
+let addr_array_initialize arr ofs newval dbg =
+ Cop(Cextcall("caml_initialize", typ_void, false, None),
+ [array_indexing log2_size_addr arr ofs dbg; newval], dbg)
+let int_array_set arr ofs newval dbg =
Cop(Cstore (Word_int, Assignment),
- [array_indexing log2_size_addr arr ofs; newval])
-let float_array_set arr ofs newval =
+ [array_indexing log2_size_addr arr ofs dbg; newval], dbg)
+let float_array_set arr ofs newval dbg =
Cop(Cstore (Double_u, Assignment),
- [array_indexing log2_size_float arr ofs; newval])
+ [array_indexing log2_size_float arr ofs dbg; newval], dbg)
(* String length *)
(* Length of string block *)
-let string_length exp =
+let string_length exp dbg =
bind "str" exp (fun str ->
let tmp_var = Ident.create "tmp" in
Clet(tmp_var,
Cop(Csubi,
[Cop(Clsl,
- [get_size str;
- Cconst_int log2_size_addr]);
- Cconst_int 1]),
+ [get_size str dbg;
+ Cconst_int log2_size_addr],
+ dbg);
+ Cconst_int 1],
+ dbg),
Cop(Csubi,
[Cvar tmp_var;
- Cop(Cload Byte_unsigned,
- [Cop(Cadda, [str; Cvar tmp_var])])])))
+ Cop(Cload (Byte_unsigned, Mutable),
+ [Cop(Cadda, [str; Cvar tmp_var], dbg)], dbg)], dbg)))
(* Message sending *)
-let lookup_tag obj tag =
+let lookup_tag obj tag dbg =
bind "tag" tag (fun tag ->
- Cop(Cextcall("caml_get_public_method", typ_val, false, Debuginfo.none,
- None),
- [obj; tag]))
+ Cop(Cextcall("caml_get_public_method", typ_val, false, None),
+ [obj; tag],
+ dbg))
-let lookup_label obj lab =
+let lookup_label obj lab dbg =
bind "lab" lab (fun lab ->
- let table = Cop (Cload Word_val, [obj]) in
- addr_array_ref table lab)
+ let table = Cop (Cload (Word_val, Mutable), [obj], dbg) in
+ addr_array_ref table lab dbg)
let call_cached_method obj tag cache pos args dbg =
let arity = List.length args in
- let cache = array_indexing log2_size_addr cache pos in
+ let cache = array_indexing log2_size_addr cache pos dbg in
Compilenv.need_send_fun arity;
- Cop(Capply (typ_val, dbg),
+ Cop(Capply typ_val,
Cconst_symbol("caml_send" ^ string_of_int arity) ::
- obj :: tag :: cache :: args)
+ obj :: tag :: cache :: args,
+ dbg)
(* Allocation *)
let make_alloc_generic set_fn dbg tag wordsize args =
if wordsize <= Config.max_young_wosize then
- Cop(Calloc dbg, Cblockheader(block_header tag wordsize, dbg) :: args)
+ Cop(Calloc, Cblockheader(block_header tag wordsize, dbg) :: args, dbg)
else begin
let id = Ident.create "alloc" in
let rec fill_fields idx = function
[] -> Cvar id
- | e1::el -> Csequence(set_fn (Cvar id) (Cconst_int idx) e1,
+ | e1::el -> Csequence(set_fn (Cvar id) (Cconst_int idx) e1 dbg,
fill_fields (idx + 2) el) in
Clet(id,
- Cop(Cextcall("caml_alloc", typ_val, true, Debuginfo.none, None),
- [Cconst_int wordsize; Cconst_int tag]),
+ Cop(Cextcall("caml_alloc", typ_val, true, None),
+ [Cconst_int wordsize; Cconst_int tag], dbg),
fill_fields 1 args)
end
let make_alloc dbg tag args =
- make_alloc_generic addr_array_set dbg tag (List.length args) args
+ let addr_array_init arr ofs newval dbg =
+ Cop(Cextcall("caml_initialize", typ_void, false, None),
+ [array_indexing log2_size_addr arr ofs dbg; newval], dbg)
+ in
+ make_alloc_generic addr_array_init 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 *)
let make_checkbound dbg = function
- | [Cop(Clsr, [a1; Cconst_int n]); Cconst_int m] when (m lsl n) > n ->
- Cop(Ccheckbound dbg, [a1; Cconst_int(m lsl n + 1 lsl n - 1)])
+ | [Cop(Clsr, [a1; Cconst_int n], _); Cconst_int m] when (m lsl n) > n ->
+ Cop(Ccheckbound, [a1; Cconst_int(m lsl n + 1 lsl n - 1)], dbg)
| args ->
- Cop(Ccheckbound dbg, args)
+ Cop(Ccheckbound, args, dbg)
(* To compile "let rec" over values *)
type is_global = Global | Not_global
-let constant_closures =
- ref ([] : ((string * is_global) * ufunction list * uconstant list) list)
+type symbol_defn = string * is_global
+
+type cmm_constant =
+ | Const_closure of symbol_defn * ufunction list * uconstant list
+ | Const_table of symbol_defn * data_item list
+
+let cmm_constants =
+ ref ([] : cmm_constant list)
+
+let add_cmm_constant c =
+ cmm_constants := c :: !cmm_constants
(* Boxed integers *)
| _ ->
let arg' =
if bi = Pint32 && size_int = 8 && big_endian
- then Cop(Clsl, [arg; Cconst_int 32])
+ then Cop(Clsl, [arg; Cconst_int 32], dbg)
else arg in
- Cop(Calloc dbg, [alloc_header_boxed_int bi dbg;
+ Cop(Calloc, [alloc_header_boxed_int bi dbg;
Cconst_symbol(operations_boxed_int bi);
- arg'])
+ arg'], dbg)
-let split_int64_for_32bit_target arg =
+let split_int64_for_32bit_target arg dbg =
bind "split_int64" arg (fun arg ->
- let first = Cop (Cadda, [Cconst_int size_int; arg]) in
- let second = Cop (Cadda, [Cconst_int (2 * size_int); arg]) in
- Ctuple [Cop (Cload Thirtytwo_unsigned, [first]);
- Cop (Cload Thirtytwo_unsigned, [second])])
+ let first = Cop (Cadda, [Cconst_int size_int; arg], dbg) in
+ let second = Cop (Cadda, [Cconst_int (2 * size_int); arg], dbg) in
+ Ctuple [Cop (Cload (Thirtytwo_unsigned, Mutable), [first], dbg);
+ Cop (Cload (Thirtytwo_unsigned, Mutable), [second], dbg)])
-let rec unbox_int bi arg =
+let rec unbox_int bi arg dbg =
match arg with
- Cop(Calloc _, [_hdr; _ops; Cop(Clsl, [contents; Cconst_int 32])])
+ Cop(Calloc, [_hdr; _ops; Cop(Clsl, [contents; Cconst_int 32], dbg')], dbg)
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(Casr, [Cop(Clsl, [contents; Cconst_int 32], dbg'); Cconst_int 32],
+ dbg)
+ | Cop(Calloc, [_hdr; _ops; contents], dbg)
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(Casr, [Cop(Clsl, [contents; Cconst_int 32], dbg); Cconst_int 32], dbg)
+ | Cop(Calloc, [_hdr; _ops; contents], _dbg) ->
contents
- | Clet(id, exp, body) -> Clet(id, exp, unbox_int bi body)
+ | Clet(id, exp, body) -> Clet(id, exp, unbox_int bi body dbg)
| Cifthenelse(cond, e1, e2) ->
- Cifthenelse(cond, unbox_int bi e1, unbox_int bi e2)
- | Csequence(e1, e2) -> Csequence(e1, unbox_int bi e2)
- | Cswitch(e, tbl, el) -> Cswitch(e, tbl, Array.map (unbox_int bi) el)
- | Ccatch(n, ids, e1, e2) -> Ccatch(n, ids, unbox_int bi e1, unbox_int bi e2)
- | Ctrywith(e1, id, e2) -> Ctrywith(unbox_int bi e1, id, unbox_int bi e2)
+ Cifthenelse(cond, unbox_int bi e1 dbg, unbox_int bi e2 dbg)
+ | Csequence(e1, e2) -> Csequence(e1, unbox_int bi e2 dbg)
+ | Cswitch(e, tbl, el, dbg) ->
+ Cswitch(e, tbl, Array.map (fun e -> unbox_int bi e dbg) el, dbg)
+ | Ccatch(rec_flag, handlers, body) ->
+ map_ccatch (fun e -> unbox_int bi e dbg) rec_flag handlers body
+ | Ctrywith(e1, id, e2) ->
+ Ctrywith(unbox_int bi e1 dbg, id, unbox_int bi e2 dbg)
| _ ->
if size_int = 4 && bi = Pint64 then
- split_int64_for_32bit_target arg
+ split_int64_for_32bit_target arg dbg
else
- Cop(Cload(if bi = Pint32 then Thirtytwo_signed else Word_int),
- [Cop(Cadda, [arg; Cconst_int size_addr])])
+ Cop(
+ Cload((if bi = Pint32 then Thirtytwo_signed else Word_int), Mutable),
+ [Cop(Cadda, [arg; Cconst_int size_addr], dbg)], dbg)
-let make_unsigned_int bi arg =
+let make_unsigned_int bi arg dbg =
if bi = Pint32 && size_int = 8
- then Cop(Cand, [arg; Cconst_natint 0xFFFFFFFFn])
+ then Cop(Cand, [arg; Cconst_natint 0xFFFFFFFFn], dbg)
else arg
(* Boxed numbers *)
-type boxed_number =
- | 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
| 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;
-}
-
-let empty_env =
- {
- unboxed_ids =Ident.empty;
- }
-
-let is_unboxed_id id env =
- try Some (Ident.find_same id env.unboxed_ids)
- with Not_found -> None
-
-let add_unboxed_id id unboxed_id bn env =
- {
- unboxed_ids = Ident.add id (unboxed_id, bn) env.unboxed_ids;
- }
-
-
(* Big arrays *)
let bigarray_elt_size = function
else
bind "idx" arg (fun idx ->
(* Load the untagged int bound for the given dimension *)
- let bound = Cop(Cload Word_int,[field_address b dim_ofs]) in
- let idxn = untag_int idx in
+ let bound =
+ Cop(Cload (Word_int, Mutable),[field_address b dim_ofs dbg], dbg)
+ in
+ let idxn = untag_int idx dbg in
check_ba_bound bound idxn idx)
| arg1 :: argl ->
(* The remainder of the list is transformed into a one dimensional offset
*)
let rem = ba_indexing (dim_ofs + delta_ofs) delta_ofs argl in
(* Load the untagged int bound for the given dimension *)
- let bound = Cop(Cload Word_int, [field_address b dim_ofs]) in
- if unsafe then add_int (mul_int (decr_int rem) bound) arg1
+ let bound =
+ Cop(Cload (Word_int, Mutable), [field_address b dim_ofs dbg], dbg)
+ in
+ if unsafe then add_int (mul_int (decr_int rem dbg) bound dbg) arg1 dbg
else
bind "idx" arg1 (fun idx ->
bind "bound" bound (fun bound ->
- let idxn = untag_int idx in
+ let idxn = untag_int idx dbg in
(* [offset = rem * (tag_int bound) + idx] *)
- let offset = add_int (mul_int (decr_int rem) bound) idx in
+ let offset =
+ add_int (mul_int (decr_int rem dbg) bound dbg) idx dbg
+ in
check_ba_bound bound idxn offset)) in
(* The offset as an expression evaluating to int *)
let offset =
| Pbigarray_c_layout ->
ba_indexing (4 + List.length args) (-1) (List.rev args)
| Pbigarray_fortran_layout ->
- ba_indexing 5 1 (List.map (fun idx -> sub_int idx (Cconst_int 2)) args)
+ ba_indexing 5 1
+ (List.map (fun idx -> sub_int idx (Cconst_int 2) dbg) args)
and elt_size =
bigarray_elt_size elt_kind in
(* [array_indexing] can simplify the given expressions *)
array_indexing ~typ:Int (log2 elt_size)
- (Cop(Cload Word_int, [field_address b 1])) offset
+ (Cop(Cload (Word_int, Mutable),
+ [field_address b 1 dbg], dbg)) offset dbg
let bigarray_word_kind = function
Pbigarray_unknown -> assert false
bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg)
(fun addr ->
box_complex dbg
- (Cop(Cload kind, [addr]))
- (Cop(Cload kind, [Cop(Cadda, [addr; Cconst_int sz])])))
+ (Cop(Cload (kind, Mutable), [addr], dbg))
+ (Cop(Cload (kind, Mutable),
+ [Cop(Cadda, [addr; Cconst_int sz], dbg)], dbg)))
| _ ->
- Cop(Cload (bigarray_word_kind elt_kind),
- [bigarray_indexing unsafe elt_kind layout b args dbg]))
+ Cop(Cload (bigarray_word_kind elt_kind, Mutable),
+ [bigarray_indexing unsafe elt_kind layout b args dbg],
+ dbg))
let bigarray_set unsafe elt_kind layout b args newval dbg =
bind "ba" b (fun b ->
bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg)
(fun addr ->
Csequence(
- Cop(Cstore (kind, Assignment), [addr; complex_re newv]),
+ Cop(Cstore (kind, Assignment), [addr; complex_re newv dbg], dbg),
Cop(Cstore (kind, Assignment),
- [Cop(Cadda, [addr; Cconst_int sz]); complex_im newv]))))
+ [Cop(Cadda, [addr; Cconst_int sz], dbg); complex_im newv dbg],
+ dbg))))
| _ ->
Cop(Cstore (bigarray_word_kind elt_kind, Assignment),
- [bigarray_indexing unsafe elt_kind layout b args dbg; newval]))
+ [bigarray_indexing unsafe elt_kind layout b args dbg; newval],
+ dbg))
-let unaligned_load_16 ptr idx =
+let unaligned_load_16 ptr idx dbg =
if Arch.allow_unaligned_access
- then Cop(Cload Sixteen_unsigned, [add_int ptr idx])
+ then Cop(Cload (Sixteen_unsigned, Mutable), [add_int ptr idx dbg], dbg)
else
- let v1 = Cop(Cload Byte_unsigned, [add_int ptr idx]) in
- let v2 = Cop(Cload Byte_unsigned,
- [add_int (add_int ptr idx) (Cconst_int 1)]) in
+ let v1 = Cop(Cload (Byte_unsigned, Mutable), [add_int ptr idx dbg], dbg) in
+ let v2 = Cop(Cload (Byte_unsigned, Mutable),
+ [add_int (add_int ptr idx dbg) (Cconst_int 1) dbg], dbg) in
let b1, b2 = if Arch.big_endian then v1, v2 else v2, v1 in
- Cop(Cor, [lsl_int b1 (Cconst_int 8); b2])
+ Cop(Cor, [lsl_int b1 (Cconst_int 8) dbg; b2], dbg)
-let unaligned_set_16 ptr idx newval =
+let unaligned_set_16 ptr idx newval dbg =
if Arch.allow_unaligned_access
- then Cop(Cstore (Sixteen_unsigned, Assignment), [add_int ptr idx; newval])
+ then
+ Cop(Cstore (Sixteen_unsigned, Assignment),
+ [add_int ptr idx dbg; newval], dbg)
else
- let v1 = Cop(Cand, [Cop(Clsr, [newval; Cconst_int 8]); Cconst_int 0xFF]) in
- let v2 = Cop(Cand, [newval; Cconst_int 0xFF]) in
+ let v1 =
+ Cop(Cand, [Cop(Clsr, [newval; Cconst_int 8], dbg); Cconst_int 0xFF], dbg)
+ in
+ let v2 = Cop(Cand, [newval; Cconst_int 0xFF], dbg) in
let b1, b2 = if Arch.big_endian then v1, v2 else v2, v1 in
Csequence(
- Cop(Cstore (Byte_unsigned, Assignment), [add_int ptr idx; b1]),
+ Cop(Cstore (Byte_unsigned, Assignment), [add_int ptr idx dbg; b1], dbg),
Cop(Cstore (Byte_unsigned, Assignment),
- [add_int (add_int ptr idx) (Cconst_int 1); b2]))
+ [add_int (add_int ptr idx dbg) (Cconst_int 1) dbg; b2], dbg))
-let unaligned_load_32 ptr idx =
+let unaligned_load_32 ptr idx dbg =
if Arch.allow_unaligned_access
- then Cop(Cload Thirtytwo_unsigned, [add_int ptr idx])
+ then Cop(Cload (Thirtytwo_unsigned, Mutable), [add_int ptr idx dbg], dbg)
else
- let v1 = Cop(Cload Byte_unsigned, [add_int ptr idx]) in
- let v2 = Cop(Cload Byte_unsigned,
- [add_int (add_int ptr idx) (Cconst_int 1)]) in
- let v3 = Cop(Cload Byte_unsigned,
- [add_int (add_int ptr idx) (Cconst_int 2)]) in
- let v4 = Cop(Cload Byte_unsigned,
- [add_int (add_int ptr idx) (Cconst_int 3)]) in
+ let v1 = Cop(Cload (Byte_unsigned, Mutable), [add_int ptr idx dbg], dbg) in
+ let v2 = Cop(Cload (Byte_unsigned, Mutable),
+ [add_int (add_int ptr idx dbg) (Cconst_int 1) dbg], dbg) in
+ let v3 = Cop(Cload (Byte_unsigned, Mutable),
+ [add_int (add_int ptr idx dbg) (Cconst_int 2) dbg], dbg) in
+ let v4 = Cop(Cload (Byte_unsigned, Mutable),
+ [add_int (add_int ptr idx dbg) (Cconst_int 3) dbg], dbg) in
let b1, b2, b3, b4 =
if Arch.big_endian
then v1, v2, v3, v4
else v4, v3, v2, v1 in
Cop(Cor,
- [Cop(Cor, [lsl_int b1 (Cconst_int 24); lsl_int b2 (Cconst_int 16)]);
- Cop(Cor, [lsl_int b3 (Cconst_int 8); b4])])
+ [Cop(Cor, [lsl_int b1 (Cconst_int 24) dbg;
+ lsl_int b2 (Cconst_int 16) dbg], dbg);
+ Cop(Cor, [lsl_int b3 (Cconst_int 8) dbg; b4], dbg)],
+ dbg)
-let unaligned_set_32 ptr idx newval =
+let unaligned_set_32 ptr idx newval dbg =
if Arch.allow_unaligned_access
- then Cop(Cstore (Thirtytwo_unsigned, Assignment), [add_int ptr idx; newval])
+ then
+ Cop(Cstore (Thirtytwo_unsigned, Assignment), [add_int ptr idx dbg; newval],
+ dbg)
else
let v1 =
- Cop(Cand, [Cop(Clsr, [newval; Cconst_int 24]); Cconst_int 0xFF]) in
+ Cop(Cand, [Cop(Clsr, [newval; Cconst_int 24], dbg); Cconst_int 0xFF], dbg)
+ in
let v2 =
- Cop(Cand, [Cop(Clsr, [newval; Cconst_int 16]); Cconst_int 0xFF]) in
+ Cop(Cand, [Cop(Clsr, [newval; Cconst_int 16], dbg); Cconst_int 0xFF], dbg)
+ in
let v3 =
- Cop(Cand, [Cop(Clsr, [newval; Cconst_int 8]); Cconst_int 0xFF]) in
- let v4 = Cop(Cand, [newval; Cconst_int 0xFF]) in
+ Cop(Cand, [Cop(Clsr, [newval; Cconst_int 8], dbg); Cconst_int 0xFF], dbg)
+ in
+ let v4 = Cop(Cand, [newval; Cconst_int 0xFF], dbg) in
let b1, b2, b3, b4 =
if Arch.big_endian
then v1, v2, v3, v4
else v4, v3, v2, v1 in
Csequence(
Csequence(
- Cop(Cstore (Byte_unsigned, Assignment), [add_int ptr idx; b1]),
Cop(Cstore (Byte_unsigned, Assignment),
- [add_int (add_int ptr idx) (Cconst_int 1); b2])),
+ [add_int ptr idx dbg; b1], dbg),
+ Cop(Cstore (Byte_unsigned, Assignment),
+ [add_int (add_int ptr idx dbg) (Cconst_int 1) dbg; b2], dbg)),
Csequence(
Cop(Cstore (Byte_unsigned, Assignment),
- [add_int (add_int ptr idx) (Cconst_int 2); b3]),
+ [add_int (add_int ptr idx dbg) (Cconst_int 2) dbg; b3], dbg),
Cop(Cstore (Byte_unsigned, Assignment),
- [add_int (add_int ptr idx) (Cconst_int 3); b4])))
+ [add_int (add_int ptr idx dbg) (Cconst_int 3) dbg; b4], dbg)))
-let unaligned_load_64 ptr idx =
+let unaligned_load_64 ptr idx dbg =
assert(size_int = 8);
if Arch.allow_unaligned_access
- then Cop(Cload Word_int, [add_int ptr idx])
+ then Cop(Cload (Word_int, Mutable), [add_int ptr idx dbg], dbg)
else
- let v1 = Cop(Cload Byte_unsigned, [add_int ptr idx]) in
- let v2 = Cop(Cload Byte_unsigned,
- [add_int (add_int ptr idx) (Cconst_int 1)]) in
- let v3 = Cop(Cload Byte_unsigned,
- [add_int (add_int ptr idx) (Cconst_int 2)]) in
- let v4 = Cop(Cload Byte_unsigned,
- [add_int (add_int ptr idx) (Cconst_int 3)]) in
- let v5 = Cop(Cload Byte_unsigned,
- [add_int (add_int ptr idx) (Cconst_int 4)]) in
- let v6 = Cop(Cload Byte_unsigned,
- [add_int (add_int ptr idx) (Cconst_int 5)]) in
- let v7 = Cop(Cload Byte_unsigned,
- [add_int (add_int ptr idx) (Cconst_int 6)]) in
- let v8 = Cop(Cload Byte_unsigned,
- [add_int (add_int ptr idx) (Cconst_int 7)]) in
+ let v1 = Cop(Cload (Byte_unsigned, Mutable), [add_int ptr idx dbg], dbg) in
+ let v2 = Cop(Cload (Byte_unsigned, Mutable),
+ [add_int (add_int ptr idx dbg) (Cconst_int 1) dbg], dbg) in
+ let v3 = Cop(Cload (Byte_unsigned, Mutable),
+ [add_int (add_int ptr idx dbg) (Cconst_int 2) dbg], dbg) in
+ let v4 = Cop(Cload (Byte_unsigned, Mutable),
+ [add_int (add_int ptr idx dbg) (Cconst_int 3) dbg], dbg) in
+ let v5 = Cop(Cload (Byte_unsigned, Mutable),
+ [add_int (add_int ptr idx dbg) (Cconst_int 4) dbg], dbg) in
+ let v6 = Cop(Cload (Byte_unsigned, Mutable),
+ [add_int (add_int ptr idx dbg) (Cconst_int 5) dbg], dbg) in
+ let v7 = Cop(Cload (Byte_unsigned, Mutable),
+ [add_int (add_int ptr idx dbg) (Cconst_int 6) dbg], dbg) in
+ let v8 = Cop(Cload (Byte_unsigned, Mutable),
+ [add_int (add_int ptr idx dbg) (Cconst_int 7) dbg], dbg) in
let b1, b2, b3, b4, b5, b6, b7, b8 =
if Arch.big_endian
then v1, v2, v3, v4, v5, v6, v7, v8
else v8, v7, v6, v5, v4, v3, v2, v1 in
Cop(Cor,
[Cop(Cor,
- [Cop(Cor, [lsl_int b1 (Cconst_int (8*7));
- lsl_int b2 (Cconst_int (8*6))]);
- Cop(Cor, [lsl_int b3 (Cconst_int (8*5));
- lsl_int b4 (Cconst_int (8*4))])]);
+ [Cop(Cor, [lsl_int b1 (Cconst_int (8*7)) dbg;
+ lsl_int b2 (Cconst_int (8*6)) dbg], dbg);
+ Cop(Cor, [lsl_int b3 (Cconst_int (8*5)) dbg;
+ lsl_int b4 (Cconst_int (8*4)) dbg], dbg)],
+ dbg);
Cop(Cor,
- [Cop(Cor, [lsl_int b5 (Cconst_int (8*3));
- lsl_int b6 (Cconst_int (8*2))]);
- Cop(Cor, [lsl_int b7 (Cconst_int 8);
- b8])])])
+ [Cop(Cor, [lsl_int b5 (Cconst_int (8*3)) dbg;
+ lsl_int b6 (Cconst_int (8*2)) dbg], dbg);
+ Cop(Cor, [lsl_int b7 (Cconst_int 8) dbg;
+ b8], dbg)],
+ dbg)], dbg)
-let unaligned_set_64 ptr idx newval =
+let unaligned_set_64 ptr idx newval dbg =
assert(size_int = 8);
if Arch.allow_unaligned_access
- then Cop(Cstore (Word_int, Assignment), [add_int ptr idx; newval])
+ then Cop(Cstore (Word_int, Assignment), [add_int ptr idx dbg; newval], dbg)
else
let v1 =
- Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*7)]); Cconst_int 0xFF]) in
+ Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*7)], dbg); Cconst_int 0xFF],
+ dbg)
+ in
let v2 =
- Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*6)]); Cconst_int 0xFF]) in
+ Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*6)], dbg); Cconst_int 0xFF],
+ dbg)
+ in
let v3 =
- Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*5)]); Cconst_int 0xFF]) in
+ Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*5)], dbg); Cconst_int 0xFF],
+ dbg)
+ in
let v4 =
- Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*4)]); Cconst_int 0xFF]) in
+ Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*4)], dbg); Cconst_int 0xFF],
+ dbg)
+ in
let v5 =
- Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*3)]); Cconst_int 0xFF]) in
+ Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*3)], dbg); Cconst_int 0xFF],
+ dbg)
+ in
let v6 =
- Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*2)]); Cconst_int 0xFF]) in
- let v7 = Cop(Cand, [Cop(Clsr, [newval; Cconst_int 8]); Cconst_int 0xFF]) in
- let v8 = Cop(Cand, [newval; Cconst_int 0xFF]) in
+ Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*2)], dbg); Cconst_int 0xFF],
+ dbg)
+ in
+ let v7 =
+ Cop(Cand, [Cop(Clsr, [newval; Cconst_int 8], dbg); Cconst_int 0xFF],
+ dbg)
+ in
+ let v8 = Cop(Cand, [newval; Cconst_int 0xFF], dbg) in
let b1, b2, b3, b4, b5, b6, b7, b8 =
if Arch.big_endian
then v1, v2, v3, v4, v5, v6, v7, v8
Csequence(
Csequence(
Csequence(
- Cop(Cstore (Byte_unsigned, Assignment), [add_int ptr idx; b1]),
Cop(Cstore (Byte_unsigned, Assignment),
- [add_int (add_int ptr idx) (Cconst_int 1); b2])),
+ [add_int ptr idx dbg; b1],
+ dbg),
+ Cop(Cstore (Byte_unsigned, Assignment),
+ [add_int (add_int ptr idx dbg) (Cconst_int 1) dbg; b2],
+ dbg)),
Csequence(
Cop(Cstore (Byte_unsigned, Assignment),
- [add_int (add_int ptr idx) (Cconst_int 2); b3]),
+ [add_int (add_int ptr idx dbg) (Cconst_int 2) dbg; b3],
+ dbg),
Cop(Cstore (Byte_unsigned, Assignment),
- [add_int (add_int ptr idx) (Cconst_int 3); b4]))),
+ [add_int (add_int ptr idx dbg) (Cconst_int 3) dbg; b4],
+ dbg))),
Csequence(
Csequence(
Cop(Cstore (Byte_unsigned, Assignment),
- [add_int (add_int ptr idx) (Cconst_int 4); b5]),
+ [add_int (add_int ptr idx dbg) (Cconst_int 4) dbg; b5],
+ dbg),
Cop(Cstore (Byte_unsigned, Assignment),
- [add_int (add_int ptr idx) (Cconst_int 5); b6])),
+ [add_int (add_int ptr idx dbg) (Cconst_int 5) dbg; b6],
+ dbg)),
Csequence(
Cop(Cstore (Byte_unsigned, Assignment),
- [add_int (add_int ptr idx) (Cconst_int 6); b7]),
+ [add_int (add_int ptr idx dbg) (Cconst_int 6) dbg; b7],
+ dbg),
Cop(Cstore (Byte_unsigned, Assignment),
- [add_int (add_int ptr idx) (Cconst_int 7); b8]))))
+ [add_int (add_int ptr idx dbg) (Cconst_int 7) dbg; b8],
+ dbg))))
-let max_or_zero a =
+let max_or_zero a dbg =
bind "size" a (fun a ->
(* equivalent to
Cifthenelse(Cop(Ccmpi Cle, [a; Cconst_int 0]), Cconst_int 0, a)
so sign_negation&a = a
if a is negative, sign is full of 1 hence sign_negation is 0
so sign_negation&a = 0 *)
- let sign = Cop(Casr, [a; Cconst_int (size_int * 8 - 1)]) in
- let sign_negation = Cop(Cxor, [sign; Cconst_int (-1)]) in
- Cop(Cand, [sign_negation; a]))
+ let sign = Cop(Casr, [a; Cconst_int (size_int * 8 - 1)], dbg) in
+ let sign_negation = Cop(Cxor, [sign; Cconst_int (-1)], dbg) in
+ Cop(Cand, [sign_negation; a], dbg))
let check_bound unsafe dbg a1 a2 k =
if unsafe then k
- else Csequence(make_checkbound dbg [max_or_zero a1;a2], k)
+ else Csequence(make_checkbound dbg [max_or_zero a1 dbg; a2], k)
(* Simplification of some primitives into C calls *)
(* Build switchers both for constants and blocks *)
-let transl_isout h arg = tag_int (Cop(Ccmpa Clt, [h ; arg]))
+let transl_isout h arg dbg = tag_int (Cop(Ccmpa Clt, [h ; arg], dbg)) dbg
(* Build an actual switch (ie jump table) *)
+let make_switch arg cases actions dbg =
+ let is_const = function
+ (* Constant integers loaded from a table should end in 1,
+ so that Cload never produces untagged integers *)
+ | Cconst_int n
+ | Cconst_pointer n -> (n land 1) = 1
+ | Cconst_natint n
+ | Cconst_natpointer n -> (Nativeint.(to_int (logand n one) = 1))
+ | Cconst_symbol _ -> true
+ | _ -> false in
+ if Array.for_all is_const actions then
+ let to_data_item = function
+ | Cconst_int n
+ | Cconst_pointer n -> Cint (Nativeint.of_int n)
+ | Cconst_natint n
+ | Cconst_natpointer n -> Cint n
+ | Cconst_symbol s -> Csymbol_address s
+ | _ -> assert false in
+ let const_actions = Array.map to_data_item actions in
+ let table = Compilenv.new_const_symbol () in
+ add_cmm_constant (Const_table ((table, Not_global),
+ Array.to_list (Array.map (fun act ->
+ const_actions.(act)) cases)));
+ addr_array_ref (Cconst_symbol table) (tag_int arg dbg) dbg
+ else
+ Cswitch (arg,cases,actions,dbg)
+
module SArgBlocks =
struct
type primitive = operation
type act = expression
let make_const i = Cconst_int i
- let make_prim p args = Cop (p,args)
- let make_offset arg n = add_const arg n
- let make_isout h arg = Cop (Ccmpa Clt, [h ; arg])
- let make_isin h arg = Cop (Ccmpa Cge, [h ; arg])
+ (* CR mshinwell: fix debuginfo *)
+ let make_prim p args = Cop (p,args, Debuginfo.none)
+ let make_offset arg n = add_const arg n Debuginfo.none
+ let make_isout h arg = Cop (Ccmpa Clt, [h ; arg], Debuginfo.none)
+ let make_isin h arg = Cop (Ccmpa Cge, [h ; arg], Debuginfo.none)
let make_if cond ifso ifnot = Cifthenelse (cond, ifso, ifnot)
- let make_switch arg cases actions = Cswitch (arg,cases,actions)
+ let make_switch arg cases actions =
+ make_switch arg cases actions Debuginfo.none
let bind arg body = bind "switcher" arg body
let make_catch handler = match handler with
| Cexit (j,_) ->
if i=j then handler
else body
- | _ -> Ccatch (i,[],body,handler))
+ | _ -> ccatch (i,[],body,handler))
let make_exit i = Cexit (i,[])
join (is_unboxed_number ~strict env e1) e2
| _ -> No_unboxing
+(* Helper for compilation of initialization and assignment operations *)
+
+type assignment_kind = Caml_modify | Caml_initialize | Simple
+
+let assignment_kind ptr init =
+ match init, ptr with
+ | Assignment, Pointer -> Caml_modify
+ | Heap_initialization, Pointer -> Caml_initialize
+ | Assignment, Immediate
+ | Heap_initialization, Immediate
+ | Root_initialization, (Immediate | Pointer) -> Simple
+
(* Translate an expression *)
let functions = (Queue.create() : ufunction Queue.t)
let module S =
Strmatch.Make
(struct
- let string_block_length = get_size
+ let string_block_length ptr = get_size ptr Debuginfo.none
let transl_switch = transl_int_switch
end) in
S.compile
transl_constant sc
| Uclosure(fundecls, []) ->
let lbl = Compilenv.new_const_symbol() in
- constant_closures :=
- ((lbl, Not_global), fundecls, []) :: !constant_closures;
+ add_cmm_constant (
+ Const_closure ((lbl, Not_global), fundecls, []));
List.iter (fun f -> Queue.add f functions) fundecls;
Cconst_symbol lbl
| Uclosure(fundecls, clos_vars) ->
int_const f.arity ::
Cconst_symbol f.label ::
transl_fundecls (pos + 4) rem in
- Cop(Calloc Debuginfo.none, transl_fundecls 0 fundecls)
+ Cop(Calloc, transl_fundecls 0 fundecls, Debuginfo.none)
| Uoffset(arg, offset) ->
(* produces a valid Caml value, pointing just after an infix header *)
let ptr = transl env arg in
if offset = 0
then ptr
- else Cop(Caddv, [ptr; Cconst_int(offset * size_addr)])
+ else Cop(Caddv, [ptr; Cconst_int(offset * size_addr)], Debuginfo.none)
| Udirect_apply(lbl, args, dbg) ->
- Cop(Capply(typ_val, dbg), Cconst_symbol lbl :: List.map (transl env) args)
+ Cop(Capply typ_val, Cconst_symbol lbl :: List.map (transl env) args, dbg)
| Ugeneric_apply(clos, [arg], dbg) ->
bind "fun" (transl env clos) (fun clos ->
- Cop(Capply(typ_val, dbg), [get_field clos 0; transl env arg; clos]))
+ Cop(Capply typ_val, [get_field env clos 0 dbg; transl env arg; clos],
+ dbg))
| Ugeneric_apply(clos, args, dbg) ->
let arity = List.length args in
let cargs = Cconst_symbol(apply_function arity) ::
List.map (transl env) (args @ [clos]) in
- Cop(Capply(typ_val, dbg), cargs)
+ Cop(Capply typ_val, cargs, dbg)
| Usend(kind, met, obj, args, dbg) ->
let call_met obj args clos =
if args = [] then
- Cop(Capply(typ_val, dbg), [get_field clos 0;obj;clos])
+ Cop(Capply typ_val, [get_field env clos 0 dbg; obj; clos], dbg)
else
let arity = List.length args + 1 in
let cargs = Cconst_symbol(apply_function arity) :: obj ::
(List.map (transl env) args) @ [clos] in
- Cop(Capply(typ_val, dbg), cargs)
+ Cop(Capply typ_val, cargs, dbg)
in
bind "obj" (transl env obj) (fun obj ->
match kind, args with
Self, _ ->
- bind "met" (lookup_label obj (transl env met)) (call_met obj args)
+ bind "met" (lookup_label obj (transl env met) dbg)
+ (call_met obj args)
| Cached, cache :: pos :: args ->
call_cached_method obj
(transl env met) (transl env cache) (transl env pos)
(List.map (transl env) args) dbg
| _ ->
- bind "met" (lookup_tag obj (transl env met)) (call_met obj args))
+ bind "met" (lookup_tag obj (transl env met) dbg)
+ (call_met obj args))
| Ulet(str, kind, id, exp, body) ->
transl_let env str kind id exp body
| Uletrec(bindings, body) ->
| 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
+ | Pbigarray_caml_int -> force_tag_int elt dbg
+ | _ -> tag_int elt dbg
end
| (Pbigarrayset(unsafe, _num_dims, elt_kind, layout), arg1 :: argl) ->
let (argidx, argnewval) = split_last argl in
(List.map (transl env) argidx)
(match elt_kind with
Pbigarray_float32 | Pbigarray_float64 ->
- transl_unbox_float env argnewval
+ transl_unbox_float dbg env argnewval
| Pbigarray_complex32 | Pbigarray_complex64 -> transl env argnewval
- | Pbigarray_int32 -> transl_unbox_int env Pint32 argnewval
- | Pbigarray_int64 -> transl_unbox_int env Pint64 argnewval
- | Pbigarray_native_int -> transl_unbox_int env Pnativeint argnewval
- | _ -> untag_int (transl env argnewval))
+ | Pbigarray_int32 -> transl_unbox_int dbg env Pint32 argnewval
+ | Pbigarray_int64 -> transl_unbox_int dbg env Pint64 argnewval
+ | Pbigarray_native_int ->
+ transl_unbox_int dbg env Pnativeint argnewval
+ | _ -> untag_int (transl env argnewval) dbg)
dbg)
| (Pbigarraydim(n), [b]) ->
let dim_ofs = 4 + n in
- tag_int (Cop(Cload Word_int, [field_address (transl env b) dim_ofs]))
+ tag_int (Cop(Cload (Word_int, Mutable),
+ [field_address (transl env b) dim_ofs dbg],
+ dbg)) dbg
| (p, [arg]) ->
transl_prim_1 env p arg dbg
| (p, [arg1; arg2]) ->
(* Control structures *)
| Uswitch(arg, s) ->
+ let dbg = Debuginfo.none in
(* As in the bytecode interpreter, only matching against constants
can be checked *)
if Array.length s.us_index_blocks = 0 then
- Cswitch
- (untag_int (transl env arg),
- s.us_index_consts,
- Array.map (transl env) s.us_actions_consts)
+ make_switch
+ (untag_int (transl env arg) dbg)
+ s.us_index_consts
+ (Array.map (transl env) s.us_actions_consts)
+ dbg
else if Array.length s.us_index_consts = 0 then
- transl_switch env (get_tag (transl env arg))
+ transl_switch dbg env (get_tag (transl env arg) dbg)
s.us_index_blocks s.us_actions_blocks
else
bind "switch" (transl env arg) (fun arg ->
Cifthenelse(
- Cop(Cand, [arg; Cconst_int 1]),
- transl_switch env
- (untag_int arg) s.us_index_consts s.us_actions_consts,
- transl_switch env
- (get_tag arg) s.us_index_blocks s.us_actions_blocks))
+ Cop(Cand, [arg; Cconst_int 1], dbg),
+ transl_switch dbg env
+ (untag_int arg dbg) s.us_index_consts s.us_actions_consts,
+ transl_switch dbg env
+ (get_tag arg dbg) s.us_index_blocks s.us_actions_blocks))
| Ustringswitch(arg,sw,d) ->
+ let dbg = Debuginfo.none in
bind "switch" (transl env arg)
(fun arg ->
- strmatch_compile arg (Misc.may_map (transl env) d)
+ strmatch_compile dbg arg (Misc.may_map (transl env) d)
(List.map (fun (s,act) -> s,transl env act) sw))
| Ustaticfail (nfail, args) ->
Cexit (nfail, List.map (transl env) args)
| Ucatch(nfail, [], body, handler) ->
make_catch nfail (transl env body) (transl env handler)
| Ucatch(nfail, ids, body, handler) ->
- Ccatch(nfail, ids, transl env body, transl env handler)
+ ccatch(nfail, ids, transl env body, transl env handler)
| Utrywith(body, exn, handler) ->
Ctrywith(transl env body, exn, transl env handler)
| Uifthenelse(Uprim(Pnot, [arg], _), ifso, ifnot) ->
transl env (Uifthenelse(arg, ifnot, ifso))
| Uifthenelse(cond, ifso, Ustaticfail (nfail, [])) ->
- exit_if_false env cond (transl env ifso) nfail
+ let dbg = Debuginfo.none in
+ exit_if_false dbg env cond (transl env ifso) nfail
| Uifthenelse(cond, Ustaticfail (nfail, []), ifnot) ->
- exit_if_true env cond nfail (transl env ifnot)
- | Uifthenelse(Uprim(Psequand, _, _) as cond, ifso, ifnot) ->
+ let dbg = Debuginfo.none in
+ exit_if_true dbg env cond nfail (transl env ifnot)
+ | Uifthenelse(Uprim(Psequand, _, dbg) as cond, ifso, ifnot) ->
let raise_num = next_raise_count () in
make_catch
raise_num
- (exit_if_false env cond (transl env ifso) raise_num)
+ (exit_if_false dbg env cond (transl env ifso) raise_num)
(transl env ifnot)
- | Uifthenelse(Uprim(Psequor, _, _) as cond, ifso, ifnot) ->
+ | Uifthenelse(Uprim(Psequor, _, dbg) as cond, ifso, ifnot) ->
let raise_num = next_raise_count () in
make_catch
raise_num
- (exit_if_true env cond raise_num (transl env ifnot))
+ (exit_if_true dbg env cond raise_num (transl env ifnot))
(transl env ifso)
| Uifthenelse (Uifthenelse (cond, condso, condnot), ifso, ifnot) ->
+ let dbg = Debuginfo.none in
let num_true = next_raise_count () in
make_catch
num_true
(make_catch2
(fun shared_false ->
if_then_else
- (test_bool (transl env cond),
- exit_if_true env condso num_true shared_false,
- exit_if_true env condnot num_true shared_false))
+ (test_bool dbg (transl env cond),
+ exit_if_true dbg env condso num_true shared_false,
+ exit_if_true dbg env condnot num_true shared_false))
(transl env ifnot))
(transl env ifso)
| Uifthenelse(cond, ifso, ifnot) ->
- if_then_else(test_bool(transl env cond), transl env ifso,
+ let dbg = Debuginfo.none in
+ if_then_else(test_bool dbg (transl env cond), transl env ifso,
transl env ifnot)
| Usequence(exp1, exp2) ->
Csequence(remove_unit(transl env exp1), transl env exp2)
| Uwhile(cond, body) ->
+ let dbg = Debuginfo.none in
let raise_num = next_raise_count () in
return_unit
- (Ccatch
+ (ccatch
(raise_num, [],
- Cloop(exit_if_false env cond
+ Cloop(exit_if_false dbg env cond
(remove_unit(transl env body)) raise_num),
Ctuple []))
| Ufor(id, low, high, dir, body) ->
+ let dbg = Debuginfo.none in
let tst = match dir with Upto -> Cgt | Downto -> Clt in
let inc = match dir with Upto -> Caddi | Downto -> Csubi in
let raise_num = next_raise_count () in
(Clet
(id, transl env low,
bind_nonvar "bound" (transl env high) (fun high ->
- Ccatch
+ ccatch
(raise_num, [],
Cifthenelse
- (Cop(Ccmpi tst, [Cvar id; high]), Cexit (raise_num, []),
+ (Cop(Ccmpi tst, [Cvar id; high], dbg),
+ Cexit (raise_num, []),
Cloop
(Csequence
(remove_unit(transl env body),
Clet(id_prev, Cvar id,
Csequence
(Cassign(id,
- Cop(inc, [Cvar id; Cconst_int 2])),
+ Cop(inc, [Cvar id; Cconst_int 2],
+ dbg)),
Cifthenelse
- (Cop(Ccmpi Ceq, [Cvar id_prev; high]),
+ (Cop(Ccmpi Ceq, [Cvar id_prev; high],
+ dbg),
Cexit (raise_num,[]), Ctuple [])))))),
Ctuple []))))
| Uassign(id, exp) ->
+ let dbg = Debuginfo.none in
begin match is_unboxed_id id env with
| None ->
return_unit (Cassign(id, transl env exp))
| Some (unboxed_id, bn) ->
- return_unit(Cassign(unboxed_id, transl_unbox_number env bn exp))
+ return_unit(Cassign(unboxed_id,
+ transl_unbox_number dbg env bn exp))
end
| Uunreachable ->
- Cop(Cload Word_int, [Cconst_int 0])
+ let dbg = Debuginfo.none in
+ Cop(Cload (Word_int, Mutable), [Cconst_int 0], dbg)
and transl_make_array dbg env kind args =
match kind with
| Pgenarray ->
- Cop(Cextcall("caml_make_array", typ_val, true, Debuginfo.none, None),
- [make_alloc dbg 0 (List.map (transl env) args)])
+ Cop(Cextcall("caml_make_array", typ_val, true, None),
+ [make_alloc dbg 0 (List.map (transl env) args)], dbg)
| Paddrarray | Pintarray ->
make_alloc dbg 0 (List.map (transl env) args)
| Pfloatarray ->
make_float_alloc dbg Obj.double_array_tag
- (List.map (transl_unbox_float env) args)
+ (List.map (transl_unbox_float dbg env) args)
and transl_ccall env prim args dbg =
let transl_arg native_repr arg =
match native_repr with
| Same_as_ocaml_repr -> transl env arg
- | Unboxed_float -> transl_unbox_float env arg
- | Unboxed_integer bi -> transl_unbox_int env bi arg
- | Untagged_int -> untag_int (transl env arg)
+ | Unboxed_float -> transl_unbox_float dbg env arg
+ | Unboxed_integer bi -> transl_unbox_int dbg env bi arg
+ | Untagged_int -> untag_int (transl env arg) dbg
in
let rec transl_args native_repr_args args =
match native_repr_args, args with
| 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)
+ | Untagged_int -> (typ_int, (fun i -> tag_int i dbg))
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, None), args))
+ typ_res, prim.prim_alloc, None), args, dbg))
and transl_prim_1 env p arg dbg =
match p with
return_unit(remove_unit (transl env arg))
(* Heap operations *)
| Pfield n ->
- get_field (transl env arg) n
+ get_field env (transl env arg) n dbg
| Pfloatfield n ->
let ptr = transl env arg in
box_float dbg (
- Cop(Cload Double_u,
+ Cop(Cload (Double_u, Mutable),
[if n = 0 then ptr
- else Cop(Cadda, [ptr; Cconst_int(n * size_float)])]))
+ else Cop(Cadda, [ptr; Cconst_int(n * size_float)], dbg)],
+ dbg))
| Pint_as_pointer ->
- Cop(Caddi, [transl env arg; Cconst_int (-1)])
+ Cop(Caddi, [transl env arg; Cconst_int (-1)], dbg)
(* always a pointer outside the heap *)
(* Exceptions *)
| Praise _ when not (!Clflags.debug) ->
- Cop(Craise (Cmm.Raise_notrace, dbg), [transl env arg])
+ Cop(Craise Cmm.Raise_notrace, [transl env arg], dbg)
| Praise Lambda.Raise_notrace ->
- Cop(Craise (Cmm.Raise_notrace, dbg), [transl env arg])
+ Cop(Craise Cmm.Raise_notrace, [transl env arg], dbg)
| Praise Lambda.Raise_reraise ->
- Cop(Craise (Cmm.Raise_withtrace, dbg), [transl env arg])
+ Cop(Craise Cmm.Raise_withtrace, [transl env arg], dbg)
| Praise Lambda.Raise_regular ->
raise_regular dbg (transl env arg)
(* Integer operations *)
| Pnegint ->
- Cop(Csubi, [Cconst_int 2; transl env arg])
+ Cop(Csubi, [Cconst_int 2; transl env arg], dbg)
| Pctconst c ->
- let const_of_bool b = tag_int (Cconst_int (if b then 1 else 0)) in
+ let const_of_bool b = tag_int (Cconst_int (if b then 1 else 0)) dbg in
begin
match c with
| Big_endian -> const_of_bool Arch.big_endian
- | Word_size -> tag_int (Cconst_int (8*Arch.size_int))
- | Int_size -> tag_int (Cconst_int ((8*Arch.size_int) - 1))
+ | Word_size -> tag_int (Cconst_int (8*Arch.size_int)) dbg
+ | Int_size -> tag_int (Cconst_int ((8*Arch.size_int) - 1)) dbg
| Max_wosize ->
- tag_int (Cconst_int ((1 lsl ((8*Arch.size_int) - 10)) - 1 ))
+ tag_int (Cconst_int ((1 lsl ((8*Arch.size_int) - 10)) - 1 )) 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 *)
+ tag_int (Cconst_int 0) dbg (* tag 0 is the same as Native here *)
end
| Poffsetint n ->
if no_overflow_lsl n 1 then
- add_const (transl env arg) (n lsl 1)
+ add_const (transl env arg) (n lsl 1) dbg
else
transl_prim_2 env Paddint arg (Uconst (Uconst_int n))
Debuginfo.none
return_unit
(bind "ref" (transl env arg) (fun arg ->
Cop(Cstore (Word_int, Assignment),
- [arg; add_const (Cop(Cload Word_int, [arg])) (n lsl 1)])))
+ [arg;
+ add_const (Cop(Cload (Word_int, Mutable), [arg], dbg))
+ (n lsl 1) dbg],
+ dbg)))
(* Floating-point operations *)
| Pfloatofint ->
- box_float dbg (Cop(Cfloatofint, [untag_int(transl env arg)]))
+ box_float dbg (Cop(Cfloatofint, [untag_int(transl env arg) dbg], dbg))
| Pintoffloat ->
- tag_int(Cop(Cintoffloat, [transl_unbox_float env arg]))
+ tag_int(Cop(Cintoffloat, [transl_unbox_float dbg env arg], dbg)) dbg
| Pnegfloat ->
- box_float dbg (Cop(Cnegf, [transl_unbox_float env arg]))
+ box_float dbg (Cop(Cnegf, [transl_unbox_float dbg env arg], dbg))
| Pabsfloat ->
- box_float dbg (Cop(Cabsf, [transl_unbox_float env arg]))
+ box_float dbg (Cop(Cabsf, [transl_unbox_float dbg env arg], dbg))
(* String operations *)
| Pstringlength | Pbyteslength ->
- tag_int(string_length (transl env arg))
+ tag_int(string_length (transl env arg) dbg) dbg
(* Array operations *)
| Parraylength kind ->
+ let hdr = get_header_without_profinfo (transl env arg) dbg in
begin match kind with
Pgenarray ->
let len =
if wordsize_shift = numfloat_shift then
- Cop(Clsr, [header(transl env arg); Cconst_int wordsize_shift])
+ Cop(Clsr, [hdr; Cconst_int wordsize_shift], dbg)
else
- bind "header" (header(transl env arg)) (fun hdr ->
- Cifthenelse(is_addr_array_hdr hdr,
- Cop(Clsr, [hdr; Cconst_int wordsize_shift]),
- Cop(Clsr, [hdr; Cconst_int numfloat_shift]))) in
- Cop(Cor, [len; Cconst_int 1])
+ bind "header" hdr (fun hdr ->
+ Cifthenelse(is_addr_array_hdr hdr dbg,
+ Cop(Clsr, [hdr; Cconst_int wordsize_shift], dbg),
+ Cop(Clsr, [hdr; Cconst_int numfloat_shift], dbg))) in
+ Cop(Cor, [len; Cconst_int 1], dbg)
| Paddrarray | Pintarray ->
- Cop(Cor, [addr_array_length(header(transl env arg)); Cconst_int 1])
+ Cop(Cor, [addr_array_length hdr dbg; Cconst_int 1], dbg)
| Pfloatarray ->
- Cop(Cor, [float_array_length(header(transl env arg)); Cconst_int 1])
+ Cop(Cor, [float_array_length hdr dbg; Cconst_int 1], dbg)
end
(* Boolean operations *)
| Pnot ->
- Cop(Csubi, [Cconst_int 4; transl env arg]) (* 1 -> 3, 3 -> 1 *)
+ Cop(Csubi, [Cconst_int 4; transl env arg], dbg) (* 1 -> 3, 3 -> 1 *)
(* Test integer/block *)
| Pisint ->
- tag_int(Cop(Cand, [transl env arg; Cconst_int 1]))
+ tag_int(Cop(Cand, [transl env arg; Cconst_int 1], dbg)) dbg
(* Boxed integers *)
| Pbintofint bi ->
- box_int dbg bi (untag_int (transl env arg))
+ box_int dbg bi (untag_int (transl env arg) dbg)
| Pintofbint bi ->
- force_tag_int (transl_unbox_int env bi arg)
+ force_tag_int (transl_unbox_int dbg env bi arg) dbg
| Pcvtbint(bi1, bi2) ->
- box_int dbg bi2 (transl_unbox_int env bi1 arg)
+ box_int dbg bi2 (transl_unbox_int dbg env bi1 arg)
| Pnegbint bi ->
- box_int dbg bi (Cop(Csubi, [Cconst_int 0; transl_unbox_int env bi arg]))
+ box_int dbg bi
+ (Cop(Csubi, [Cconst_int 0; transl_unbox_int dbg env bi arg], dbg))
| Pbbswap bi ->
let prim = match bi with
| Pnativeint -> "nativeint"
| Pint32 -> "int32"
| Pint64 -> "int64" in
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]))
+ typ_int, false, None),
+ [transl_unbox_int dbg env bi arg],
+ dbg))
| Pbswap16 ->
- tag_int (Cop(Cextcall("caml_bswap16_direct", typ_int, false,
- Debuginfo.none, None),
- [untag_int (transl env arg)]))
+ tag_int (Cop(Cextcall("caml_bswap16_direct", typ_int, false, None),
+ [untag_int (transl env arg) dbg],
+ dbg))
+ dbg
| prim ->
fatal_errorf "Cmmgen.transl_prim_1: %a" Printlambda.primitive prim
and transl_prim_2 env p arg1 arg2 dbg =
match p with
(* Heap operations *)
- Psetfield(n, ptr, init) ->
- begin match init, ptr with
- | Assignment, Pointer ->
- 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) ->
- return_unit(set_field (transl env arg1) n (transl env arg2) init)
+ | Pfield_computed ->
+ addr_array_ref (transl env arg1) (transl env arg2) dbg
+ | Psetfield(n, ptr, init) ->
+ begin match assignment_kind ptr init with
+ | Caml_modify ->
+ return_unit(Cop(Cextcall("caml_modify", typ_void, false, None),
+ [field_address (transl env arg1) n dbg;
+ transl env arg2],
+ dbg))
+ | Caml_initialize ->
+ return_unit(Cop(Cextcall("caml_initialize", typ_void, false, None),
+ [field_address (transl env arg1) n dbg;
+ transl env arg2],
+ dbg))
+ | Simple ->
+ return_unit(set_field (transl env arg1) n (transl env arg2) init dbg)
end
| Psetfloatfield (n, init) ->
let ptr = transl env arg1 in
return_unit(
Cop(Cstore (Double_u, init),
[if n = 0 then ptr
- else Cop(Cadda, [ptr; Cconst_int(n * size_float)]);
- transl_unbox_float env arg2]))
+ else Cop(Cadda, [ptr; Cconst_int(n * size_float)], dbg);
+ transl_unbox_float dbg env arg2], dbg))
(* Boolean operations *)
| Psequand ->
- if_then_else(test_bool(transl env arg1), transl env arg2, Cconst_int 1)
+ if_then_else(test_bool dbg (transl env arg1),
+ transl env arg2, Cconst_int 1)
(* let id = Ident.create "res1" in
Clet(id, transl env arg1,
- Cifthenelse(test_bool(Cvar id), transl env arg2, Cvar id)) *)
+ Cifthenelse(test_bool dbg (Cvar id), transl env arg2, Cvar id)) *)
| Psequor ->
- if_then_else(test_bool(transl env arg1), Cconst_int 3, transl env arg2)
+ if_then_else(test_bool dbg (transl env arg1),
+ Cconst_int 3, transl env arg2)
(* Integer operations *)
| Paddint ->
- decr_int(add_int (transl env arg1) (transl env arg2))
+ decr_int(add_int (transl env arg1) (transl env arg2) dbg) dbg
| Psubint ->
- incr_int(sub_int (transl env arg1) (transl env arg2))
+ incr_int(sub_int (transl env arg1) (transl env arg2) dbg) dbg
| Pmulint ->
begin
(* decrementing the non-constant part helps when the multiplication is
*)
match transl env arg1, transl env arg2 with
| Cconst_int _ as c1, c2 ->
- incr_int (mul_int (untag_int c1) (decr_int c2))
- | c1, c2 -> incr_int (mul_int (decr_int c1) (untag_int c2))
+ incr_int (mul_int (untag_int c1 dbg) (decr_int c2 dbg) dbg) dbg
+ | c1, c2 ->
+ incr_int (mul_int (decr_int c1 dbg) (untag_int c2 dbg) dbg) dbg
end
| Pdivint is_safe ->
- tag_int(div_int (untag_int(transl env arg1))
- (untag_int(transl env arg2)) is_safe dbg)
+ tag_int(div_int (untag_int(transl env arg1) dbg)
+ (untag_int(transl env arg2) dbg) is_safe dbg) dbg
| Pmodint is_safe ->
- tag_int(mod_int (untag_int(transl env arg1))
- (untag_int(transl env arg2)) is_safe dbg)
+ tag_int(mod_int (untag_int(transl env arg1) dbg)
+ (untag_int(transl env arg2) dbg) is_safe dbg) dbg
| Pandint ->
- Cop(Cand, [transl env arg1; transl env arg2])
+ Cop(Cand, [transl env arg1; transl env arg2], dbg)
| Porint ->
- Cop(Cor, [transl env arg1; transl env arg2])
+ Cop(Cor, [transl env arg1; transl env arg2], dbg)
| Pxorint ->
Cop(Cor, [Cop(Cxor, [ignore_low_bit_int(transl env arg1);
- ignore_low_bit_int(transl env arg2)]);
- Cconst_int 1])
+ ignore_low_bit_int(transl env arg2)], dbg);
+ Cconst_int 1], dbg)
| Plslint ->
- incr_int(lsl_int (decr_int(transl env arg1)) (untag_int(transl env arg2)))
+ incr_int(lsl_int (decr_int(transl env arg1) dbg)
+ (untag_int(transl env arg2) dbg) dbg) dbg
| Plsrint ->
- Cop(Cor, [lsr_int (transl env arg1) (untag_int(transl env arg2));
- Cconst_int 1])
+ Cop(Cor, [lsr_int (transl env arg1) (untag_int(transl env arg2) dbg) dbg;
+ Cconst_int 1], dbg)
| Pasrint ->
- Cop(Cor, [asr_int (transl env arg1) (untag_int(transl env arg2));
- Cconst_int 1])
+ Cop(Cor, [asr_int (transl env arg1) (untag_int(transl env arg2) dbg) dbg;
+ Cconst_int 1], dbg)
| Pintcomp cmp ->
tag_int(Cop(Ccmpi(transl_comparison cmp),
- [transl env arg1; transl env arg2]))
+ [transl env arg1; transl env arg2], dbg)) dbg
| Pisout ->
- transl_isout (transl env arg1) (transl env arg2)
+ transl_isout (transl env arg1) (transl env arg2) dbg
(* Float operations *)
| Paddfloat ->
box_float dbg (Cop(Caddf,
- [transl_unbox_float env arg1; transl_unbox_float env arg2]))
+ [transl_unbox_float dbg env arg1; transl_unbox_float dbg env arg2],
+ dbg))
| Psubfloat ->
box_float dbg (Cop(Csubf,
- [transl_unbox_float env arg1; transl_unbox_float env arg2]))
+ [transl_unbox_float dbg env arg1; transl_unbox_float dbg env arg2],
+ dbg))
| Pmulfloat ->
box_float dbg (Cop(Cmulf,
- [transl_unbox_float env arg1; transl_unbox_float env arg2]))
+ [transl_unbox_float dbg env arg1; transl_unbox_float dbg env arg2],
+ dbg))
| Pdivfloat ->
box_float dbg (Cop(Cdivf,
- [transl_unbox_float env arg1; transl_unbox_float env arg2]))
+ [transl_unbox_float dbg env arg1; transl_unbox_float dbg env arg2],
+ dbg))
| Pfloatcomp cmp ->
tag_int(Cop(Ccmpf(transl_comparison cmp),
- [transl_unbox_float env arg1; transl_unbox_float env arg2]))
+ [transl_unbox_float dbg env arg1; transl_unbox_float dbg env arg2],
+ dbg)) dbg
(* String operations *)
| Pstringrefu | Pbytesrefu ->
- tag_int(Cop(Cload Byte_unsigned,
- [add_int (transl env arg1) (untag_int(transl env arg2))]))
+ tag_int(Cop(Cload (Byte_unsigned, Mutable),
+ [add_int (transl env arg1) (untag_int(transl env arg2) dbg)
+ dbg],
+ dbg)) dbg
| Pstringrefs | Pbytesrefs ->
tag_int
(bind "str" (transl env arg1) (fun str ->
- bind "index" (untag_int (transl env arg2)) (fun idx ->
+ bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
Csequence(
- make_checkbound dbg [string_length str; idx],
- Cop(Cload Byte_unsigned, [add_int str idx])))))
+ make_checkbound dbg [string_length str dbg; idx],
+ Cop(Cload (Byte_unsigned, Mutable),
+ [add_int str idx dbg], dbg))))) dbg
| Pstring_load_16(unsafe) ->
tag_int
(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 1))
- idx (unaligned_load_16 str idx))))
+ bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
+ check_bound unsafe dbg
+ (sub_int (string_length str dbg) (Cconst_int 1) dbg)
+ idx (unaligned_load_16 str idx dbg)))) dbg
| Pbigstring_load_16(unsafe) ->
tag_int
(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]))
+ bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
+ bind "ba_data"
+ (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg))
(fun ba_data ->
- check_bound unsafe dbg (sub_int (Cop(Cload Word_int,
- [field_address ba 5]))
- (Cconst_int 1)) idx
- (unaligned_load_16 ba_data idx)))))
+ check_bound unsafe dbg (sub_int (Cop(Cload (Word_int, Mutable),
+ [field_address ba 5 dbg], dbg))
+ (Cconst_int 1) dbg) idx
+ (unaligned_load_16 ba_data idx dbg))))) dbg
| Pstring_load_32(unsafe) ->
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))))
+ bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
+ check_bound unsafe dbg
+ (sub_int (string_length str dbg) (Cconst_int 3) dbg)
+ idx (unaligned_load_32 str idx dbg))))
| Pbigstring_load_32(unsafe) ->
box_int dbg Pint32
(bind "ba" (transl env arg1) (fun ba ->
- bind "index" (untag_int (transl env arg2)) (fun idx ->
- bind "ba_data" (Cop(Cload Word_int, [field_address ba 1]))
+ bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
+ bind "ba_data"
+ (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg))
(fun ba_data ->
- check_bound unsafe dbg (sub_int (Cop(Cload Word_int,
- [field_address ba 5]))
- (Cconst_int 3)) idx
- (unaligned_load_32 ba_data idx)))))
+ check_bound unsafe dbg (sub_int (Cop(Cload (Word_int, Mutable),
+ [field_address ba 5 dbg], dbg))
+ (Cconst_int 3) dbg) idx
+ (unaligned_load_32 ba_data idx dbg)))))
| Pstring_load_64(unsafe) ->
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))))
+ bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
+ check_bound unsafe dbg
+ (sub_int (string_length str dbg) (Cconst_int 7) dbg)
+ idx (unaligned_load_64 str idx dbg))))
| Pbigstring_load_64(unsafe) ->
box_int dbg Pint64
(bind "ba" (transl env arg1) (fun ba ->
- bind "index" (untag_int (transl env arg2)) (fun idx ->
- bind "ba_data" (Cop(Cload Word_int, [field_address ba 1]))
+ bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
+ bind "ba_data"
+ (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg))
(fun ba_data ->
- check_bound unsafe dbg (sub_int (Cop(Cload Word_int,
- [field_address ba 5]))
- (Cconst_int 7)) idx
- (unaligned_load_64 ba_data idx)))))
+ check_bound unsafe dbg (sub_int (Cop(Cload (Word_int, Mutable),
+ [field_address ba 5 dbg], dbg))
+ (Cconst_int 7) dbg) idx
+ (unaligned_load_64 ba_data idx dbg)))))
(* Array operations *)
| Parrayrefu kind ->
Pgenarray ->
bind "arr" (transl env arg1) (fun arr ->
bind "index" (transl env arg2) (fun idx ->
- Cifthenelse(is_addr_array_ptr arr,
- addr_array_ref arr idx,
+ Cifthenelse(is_addr_array_ptr arr dbg,
+ addr_array_ref arr idx dbg,
float_array_ref dbg arr idx)))
| Paddrarray ->
- addr_array_ref (transl env arg1) (transl env arg2)
+ addr_array_ref (transl env arg1) (transl env arg2) dbg
| Pintarray ->
- int_array_ref (transl env arg1) (transl env arg2)
+ (* CR mshinwell: for int/addr_array_ref move "dbg" to first arg *)
+ int_array_ref (transl env arg1) (transl env arg2) dbg
| Pfloatarray ->
float_array_ref dbg (transl env arg1) (transl env arg2)
end
| Pgenarray ->
bind "index" (transl env arg2) (fun idx ->
bind "arr" (transl env arg1) (fun arr ->
- bind "header" (header arr) (fun hdr ->
+ bind "header" (get_header_without_profinfo arr dbg) (fun hdr ->
if wordsize_shift = numfloat_shift then
- Csequence(make_checkbound dbg [addr_array_length hdr; idx],
- Cifthenelse(is_addr_array_hdr hdr,
- addr_array_ref arr idx,
+ Csequence(make_checkbound dbg [addr_array_length hdr dbg; idx],
+ Cifthenelse(is_addr_array_hdr hdr dbg,
+ addr_array_ref arr idx dbg,
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],
+ Cifthenelse(is_addr_array_hdr hdr dbg,
+ Csequence(make_checkbound dbg [addr_array_length hdr dbg; idx],
+ addr_array_ref arr idx dbg),
+ Csequence(make_checkbound dbg [float_array_length hdr dbg; idx],
float_array_ref dbg arr idx)))))
| Paddrarray ->
bind "index" (transl env arg2) (fun idx ->
bind "arr" (transl env arg1) (fun arr ->
- Csequence(make_checkbound dbg [addr_array_length(header arr); idx],
- addr_array_ref arr idx)))
+ Csequence(make_checkbound dbg [
+ addr_array_length(get_header_without_profinfo arr dbg) dbg; idx],
+ addr_array_ref arr idx dbg)))
| Pintarray ->
bind "index" (transl env arg2) (fun idx ->
bind "arr" (transl env arg1) (fun arr ->
- Csequence(make_checkbound dbg [addr_array_length(header arr); idx],
- int_array_ref arr idx)))
+ Csequence(make_checkbound dbg [
+ addr_array_length(get_header_without_profinfo arr dbg) dbg; idx],
+ int_array_ref arr idx dbg)))
| Pfloatarray ->
box_float dbg (
bind "index" (transl env arg2) (fun idx ->
bind "arr" (transl env arg1) (fun arr ->
Csequence(make_checkbound dbg
- [float_array_length(header arr); idx],
- unboxed_float_array_ref arr idx))))
+ [float_array_length(get_header_without_profinfo arr dbg) dbg;
+ idx],
+ unboxed_float_array_ref arr idx dbg))))
end
(* Operations on bitvects *)
| Pbittest ->
- bind "index" (untag_int(transl env arg2)) (fun idx ->
+ bind "index" (untag_int(transl env arg2) dbg) (fun idx ->
tag_int(
- Cop(Cand, [Cop(Clsr, [Cop(Cload Byte_unsigned,
+ Cop(Cand, [Cop(Clsr, [Cop(Cload (Byte_unsigned, Mutable),
[add_int (transl env arg1)
- (Cop(Clsr, [idx; Cconst_int 3]))]);
- Cop(Cand, [idx; Cconst_int 7])]);
- Cconst_int 1])))
+ (Cop(Clsr, [idx; Cconst_int 3], dbg))
+ dbg],
+ dbg);
+ Cop(Cand, [idx; Cconst_int 7], dbg)], dbg);
+ Cconst_int 1], dbg)) dbg)
(* Boxed integers *)
| Paddbint bi ->
box_int dbg bi (Cop(Caddi,
- [transl_unbox_int env bi arg1;
- transl_unbox_int env bi arg2]))
+ [transl_unbox_int dbg env bi arg1;
+ transl_unbox_int dbg env bi arg2], dbg))
| Psubbint bi ->
box_int dbg bi (Cop(Csubi,
- [transl_unbox_int env bi arg1;
- transl_unbox_int env bi arg2]))
+ [transl_unbox_int dbg env bi arg1;
+ transl_unbox_int dbg env bi arg2], dbg))
| Pmulbint bi ->
box_int dbg bi (Cop(Cmuli,
- [transl_unbox_int env bi arg1;
- transl_unbox_int env bi arg2]))
+ [transl_unbox_int dbg env bi arg1;
+ transl_unbox_int dbg env bi arg2], dbg))
| 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)
+ (transl_unbox_int dbg env bi arg1)
+ (transl_unbox_int dbg env bi arg2)
bi dbg)
| 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)
+ (transl_unbox_int dbg env bi arg1)
+ (transl_unbox_int dbg env bi arg2)
bi dbg)
| Pandbint bi ->
box_int dbg bi (Cop(Cand,
- [transl_unbox_int env bi arg1;
- transl_unbox_int env bi arg2]))
+ [transl_unbox_int dbg env bi arg1;
+ transl_unbox_int dbg env bi arg2], dbg))
| Porbint bi ->
box_int dbg bi (Cop(Cor,
- [transl_unbox_int env bi arg1;
- transl_unbox_int env bi arg2]))
+ [transl_unbox_int dbg env bi arg1;
+ transl_unbox_int dbg env bi arg2], dbg))
| Pxorbint bi ->
box_int dbg bi (Cop(Cxor,
- [transl_unbox_int env bi arg1;
- transl_unbox_int env bi arg2]))
+ [transl_unbox_int dbg env bi arg1;
+ transl_unbox_int dbg env bi arg2], dbg))
| Plslbint bi ->
box_int dbg bi (Cop(Clsl,
- [transl_unbox_int env bi arg1;
- untag_int(transl env arg2)]))
+ [transl_unbox_int dbg env bi arg1;
+ untag_int(transl env arg2) dbg], dbg))
| Plsrbint bi ->
box_int dbg bi (Cop(Clsr,
- [make_unsigned_int bi (transl_unbox_int env bi arg1);
- untag_int(transl env arg2)]))
+ [make_unsigned_int bi (transl_unbox_int dbg env bi arg1) dbg;
+ untag_int(transl env arg2) dbg], dbg))
| Pasrbint bi ->
box_int dbg bi (Cop(Casr,
- [transl_unbox_int env bi arg1;
- untag_int(transl env arg2)]))
+ [transl_unbox_int dbg env bi arg1;
+ untag_int(transl env arg2) dbg], dbg))
| Pbintcomp(bi, cmp) ->
tag_int (Cop(Ccmpi(transl_comparison cmp),
- [transl_unbox_int env bi arg1;
- transl_unbox_int env bi arg2]))
+ [transl_unbox_int dbg env bi arg1;
+ transl_unbox_int dbg env bi arg2], dbg)) dbg
| prim ->
fatal_errorf "Cmmgen.transl_prim_2: %a" Printlambda.primitive prim
and transl_prim_3 env p arg1 arg2 arg3 dbg =
match p with
+ (* Heap operations *)
+ | Psetfield_computed(ptr, init) ->
+ begin match assignment_kind ptr init with
+ | Caml_modify ->
+ return_unit (
+ addr_array_set (transl env arg1) (transl env arg2) (transl env arg3)
+ dbg)
+ | Caml_initialize ->
+ return_unit (
+ addr_array_initialize (transl env arg1) (transl env arg2)
+ (transl env arg3) dbg)
+ | Simple ->
+ return_unit (
+ int_array_set (transl env arg1) (transl env arg2) (transl env arg3)
+ dbg)
+ end
(* String operations *)
| Pbytessetu ->
return_unit(Cop(Cstore (Byte_unsigned, Assignment),
- [add_int (transl env arg1) (untag_int(transl env arg2));
- untag_int(transl env arg3)]))
+ [add_int (transl env arg1)
+ (untag_int(transl env arg2) dbg)
+ dbg;
+ untag_int(transl env arg3) dbg], dbg))
| Pbytessets ->
return_unit
(bind "str" (transl env arg1) (fun str ->
- bind "index" (untag_int (transl env arg2)) (fun idx ->
+ bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
Csequence(
- make_checkbound dbg [string_length str; idx],
+ make_checkbound dbg [string_length str dbg; idx],
Cop(Cstore (Byte_unsigned, Assignment),
- [add_int str idx; untag_int(transl env arg3)])))))
+ [add_int str idx dbg; untag_int(transl env arg3) dbg],
+ dbg)))))
(* Array operations *)
| Parraysetu kind ->
bind "newval" (transl env arg3) (fun newval ->
bind "index" (transl env arg2) (fun index ->
bind "arr" (transl env arg1) (fun arr ->
- Cifthenelse(is_addr_array_ptr arr,
- addr_array_set arr index newval,
- float_array_set arr index (unbox_float newval)))))
+ Cifthenelse(is_addr_array_ptr arr dbg,
+ addr_array_set arr index newval dbg,
+ float_array_set arr index (unbox_float dbg newval)
+ dbg))))
| Paddrarray ->
addr_array_set (transl env arg1) (transl env arg2) (transl env arg3)
+ dbg
| Pintarray ->
int_array_set (transl env arg1) (transl env arg2) (transl env arg3)
+ dbg
| Pfloatarray ->
float_array_set (transl env arg1) (transl env arg2)
- (transl_unbox_float env arg3)
+ (transl_unbox_float dbg env arg3)
+ dbg
end)
| Parraysets kind ->
return_unit(begin match kind with
bind "newval" (transl env arg3) (fun newval ->
bind "index" (transl env arg2) (fun idx ->
bind "arr" (transl env arg1) (fun arr ->
- bind "header" (header arr) (fun hdr ->
+ bind "header" (get_header_without_profinfo arr dbg) (fun hdr ->
if wordsize_shift = numfloat_shift then
- Csequence(make_checkbound dbg [addr_array_length hdr; idx],
- Cifthenelse(is_addr_array_hdr hdr,
- addr_array_set arr idx newval,
+ Csequence(make_checkbound dbg [addr_array_length hdr dbg; idx],
+ Cifthenelse(is_addr_array_hdr hdr dbg,
+ addr_array_set arr idx newval dbg,
float_array_set arr idx
- (unbox_float newval)))
+ (unbox_float dbg newval)
+ dbg))
else
- Cifthenelse(is_addr_array_hdr hdr,
- Csequence(make_checkbound dbg [addr_array_length hdr; idx],
- addr_array_set arr idx newval),
- Csequence(make_checkbound dbg [float_array_length hdr; idx],
+ Cifthenelse(is_addr_array_hdr hdr dbg,
+ Csequence(make_checkbound dbg [addr_array_length hdr dbg; idx],
+ addr_array_set arr idx newval dbg),
+ Csequence(make_checkbound dbg [float_array_length hdr dbg; idx],
float_array_set arr idx
- (unbox_float newval)))))))
+ (unbox_float dbg newval) dbg))))))
| Paddrarray ->
bind "newval" (transl env arg3) (fun newval ->
bind "index" (transl env arg2) (fun idx ->
bind "arr" (transl env arg1) (fun arr ->
- Csequence(make_checkbound dbg [addr_array_length(header arr); idx],
- addr_array_set arr idx newval))))
+ Csequence(make_checkbound dbg [
+ addr_array_length(get_header_without_profinfo arr dbg) dbg; idx],
+ addr_array_set arr idx newval dbg))))
| Pintarray ->
bind "newval" (transl env arg3) (fun newval ->
bind "index" (transl env arg2) (fun idx ->
bind "arr" (transl env arg1) (fun arr ->
- Csequence(make_checkbound dbg [addr_array_length(header arr); idx],
- int_array_set arr idx newval))))
+ Csequence(make_checkbound dbg [
+ addr_array_length(get_header_without_profinfo arr dbg) dbg; idx],
+ int_array_set arr idx newval dbg))))
| Pfloatarray ->
- bind_load "newval" (transl_unbox_float env arg3) (fun newval ->
+ bind_load "newval" (transl_unbox_float dbg env arg3) (fun newval ->
bind "index" (transl env arg2) (fun idx ->
bind "arr" (transl env arg1) (fun arr ->
- Csequence(make_checkbound dbg [float_array_length(header arr);idx],
- float_array_set arr idx newval))))
+ Csequence(make_checkbound dbg [
+ float_array_length (get_header_without_profinfo arr dbg) dbg;idx],
+ float_array_set arr idx newval dbg))))
end)
| Pstring_set_16(unsafe) ->
return_unit
(bind "str" (transl env arg1) (fun str ->
- bind "index" (untag_int (transl env arg2)) (fun idx ->
- bind "newval" (untag_int (transl env arg3)) (fun newval ->
- check_bound unsafe dbg (sub_int (string_length str) (Cconst_int 1))
- idx (unaligned_set_16 str idx newval)))))
+ bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
+ bind "newval" (untag_int (transl env arg3) dbg) (fun newval ->
+ check_bound unsafe dbg
+ (sub_int (string_length str dbg) (Cconst_int 1) dbg)
+ idx (unaligned_set_16 str idx newval dbg)))))
| Pbigstring_set_16(unsafe) ->
return_unit
(bind "ba" (transl env arg1) (fun ba ->
- bind "index" (untag_int (transl env arg2)) (fun idx ->
- bind "newval" (untag_int (transl env arg3)) (fun newval ->
- bind "ba_data" (Cop(Cload Word_int, [field_address ba 1]))
+ bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
+ bind "newval" (untag_int (transl env arg3) dbg) (fun newval ->
+ bind "ba_data"
+ (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg))
(fun ba_data ->
- check_bound unsafe dbg (sub_int (Cop(Cload Word_int,
- [field_address ba 5]))
- (Cconst_int 1))
- idx (unaligned_set_16 ba_data idx newval))))))
+ check_bound unsafe dbg (sub_int (Cop(Cload (Word_int, Mutable),
+ [field_address ba 5 dbg], dbg))
+ (Cconst_int 1)
+ dbg)
+ idx (unaligned_set_16 ba_data idx newval dbg))))))
| Pstring_set_32(unsafe) ->
return_unit
(bind "str" (transl env arg1) (fun str ->
- bind "index" (untag_int (transl env arg2)) (fun idx ->
- bind "newval" (transl_unbox_int env Pint32 arg3) (fun newval ->
- check_bound unsafe dbg (sub_int (string_length str) (Cconst_int 3))
- idx (unaligned_set_32 str idx newval)))))
+ bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
+ bind "newval" (transl_unbox_int dbg env Pint32 arg3) (fun newval ->
+ check_bound unsafe dbg
+ (sub_int (string_length str dbg) (Cconst_int 3) dbg)
+ idx (unaligned_set_32 str idx newval dbg)))))
| Pbigstring_set_32(unsafe) ->
return_unit
(bind "ba" (transl env arg1) (fun ba ->
- bind "index" (untag_int (transl env arg2)) (fun idx ->
- bind "newval" (transl_unbox_int env Pint32 arg3) (fun newval ->
- bind "ba_data" (Cop(Cload Word_int, [field_address ba 1]))
+ bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
+ bind "newval" (transl_unbox_int dbg env Pint32 arg3) (fun newval ->
+ bind "ba_data"
+ (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg))
(fun ba_data ->
- check_bound unsafe dbg (sub_int (Cop(Cload Word_int,
- [field_address ba 5]))
- (Cconst_int 3))
- idx (unaligned_set_32 ba_data idx newval))))))
+ check_bound unsafe dbg (sub_int (Cop(Cload (Word_int, Mutable),
+ [field_address ba 5 dbg], dbg))
+ (Cconst_int 3)
+ dbg)
+ idx (unaligned_set_32 ba_data idx newval dbg))))))
| Pstring_set_64(unsafe) ->
return_unit
(bind "str" (transl env arg1) (fun str ->
- bind "index" (untag_int (transl env arg2)) (fun idx ->
- bind "newval" (transl_unbox_int env Pint64 arg3) (fun newval ->
- check_bound unsafe dbg (sub_int (string_length str) (Cconst_int 7))
- idx (unaligned_set_64 str idx newval)))))
+ bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
+ bind "newval" (transl_unbox_int dbg env Pint64 arg3) (fun newval ->
+ check_bound unsafe dbg
+ (sub_int (string_length str dbg) (Cconst_int 7) dbg)
+ idx (unaligned_set_64 str idx newval dbg)))))
| Pbigstring_set_64(unsafe) ->
return_unit
(bind "ba" (transl env arg1) (fun ba ->
- bind "index" (untag_int (transl env arg2)) (fun idx ->
- bind "newval" (transl_unbox_int env Pint64 arg3) (fun newval ->
- bind "ba_data" (Cop(Cload Word_int, [field_address ba 1]))
+ bind "index" (untag_int (transl env arg2) dbg) (fun idx ->
+ bind "newval" (transl_unbox_int dbg env Pint64 arg3) (fun newval ->
+ bind "ba_data"
+ (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg))
(fun ba_data ->
- check_bound unsafe dbg (sub_int (Cop(Cload Word_int,
- [field_address ba 5]))
- (Cconst_int 7)) idx
- (unaligned_set_64 ba_data idx newval))))))
+ check_bound unsafe dbg (sub_int (Cop(Cload (Word_int, Mutable),
+ [field_address ba 5 dbg], dbg))
+ (Cconst_int 7)
+ dbg) idx
+ (unaligned_set_64 ba_data idx newval dbg))))))
| prim ->
fatal_errorf "Cmmgen.transl_prim_3: %a" Printlambda.primitive prim
-and transl_unbox_float env = function
+and transl_unbox_float dbg env = function
Uconst(Uconst_ref(_, Some (Uconst_float f))) -> Cconst_float f
- | exp -> unbox_float(transl env exp)
+ | exp -> unbox_float dbg (transl env exp)
-and transl_unbox_int env bi = function
+and transl_unbox_int dbg env bi = function
Uconst(Uconst_ref(_, Some (Uconst_int32 n))) ->
Cconst_natint (Nativeint.of_int32 n)
| Uconst(Uconst_ref(_, Some (Uconst_nativeint n))) ->
end
| Uprim(Pbintofint bi',[Uconst(Uconst_int i)],_) when bi = bi' ->
Cconst_int i
- | exp -> unbox_int bi (transl env exp)
+ | exp -> unbox_int bi (transl env exp) dbg
-and transl_unbox_number env bn arg =
+and transl_unbox_number dbg env bn arg =
match bn with
- | Boxed_float _ -> transl_unbox_float env arg
- | Boxed_integer (bi, _) -> transl_unbox_int env bi arg
+ | Boxed_float _ -> transl_unbox_float dbg env arg
+ | Boxed_integer (bi, _) -> transl_unbox_int dbg env bi arg
and transl_let env str kind id exp body =
+ let dbg = Debuginfo.none in
let unboxing =
(* If [id] is a mutable variable (introduced to eliminate a local
reference) and it contains a type of unboxable numbers, then
used in loops and we really want to avoid repeated boxing. *)
match str, kind with
| Mutable, Pfloatval ->
- Boxed (Boxed_float Debuginfo.none, false)
+ Boxed (Boxed_float dbg, false)
| Mutable, Pboxedintval bi ->
- Boxed (Boxed_integer (bi, Debuginfo.none), false)
+ Boxed (Boxed_integer (bi, dbg), 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
No_unboxing
in
match unboxing with
- | No_unboxing | Boxed (_, true) ->
+ | No_unboxing | Boxed (_, true) | No_result ->
+ (* N.B. [body] must still be traversed even if [exp] will never return:
+ there may be constant closures inside that need lifting out. *)
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, _false) ->
let unboxed_id = Ident.create (Ident.name id) in
- Clet(unboxed_id, transl_unbox_number env boxed_number exp,
+ Clet(unboxed_id, transl_unbox_number dbg env boxed_number exp,
transl (add_unboxed_id id unboxed_id boxed_number env) body)
and make_catch ncatch body handler = match body with
| Cexit (nexit,[]) when nexit=ncatch -> handler
-| _ -> Ccatch (ncatch, [], body, handler)
+| _ -> ccatch (ncatch, [], body, handler)
and make_catch2 mk_body handler = match handler with
| Cexit (_,[])|Ctuple []|Cconst_int _|Cconst_pointer _ ->
(mk_body (Cexit (nfail,[])))
handler
-and exit_if_true env cond nfail otherwise =
+and exit_if_true dbg env cond nfail otherwise =
match cond with
| Uconst (Uconst_ptr 0) -> otherwise
| Uconst (Uconst_ptr 1) -> Cexit (nfail,[])
| Uifthenelse (arg1, Uconst (Uconst_ptr 1), arg2)
| Uprim(Psequor, [arg1; arg2], _) ->
- exit_if_true env arg1 nfail (exit_if_true env arg2 nfail otherwise)
+ exit_if_true dbg env arg1 nfail
+ (exit_if_true dbg env arg2 nfail otherwise)
| Uifthenelse (_, _, Uconst (Uconst_ptr 0))
| Uprim(Psequand, _, _) ->
begin match otherwise with
| Cexit (raise_num,[]) ->
- exit_if_false env cond (Cexit (nfail,[])) raise_num
+ exit_if_false dbg env cond (Cexit (nfail,[])) raise_num
| _ ->
let raise_num = next_raise_count () in
make_catch
raise_num
- (exit_if_false env cond (Cexit (nfail,[])) raise_num)
+ (exit_if_false dbg env cond (Cexit (nfail,[])) raise_num)
otherwise
end
| Uprim(Pnot, [arg], _) ->
- exit_if_false env arg otherwise nfail
+ exit_if_false dbg env arg otherwise nfail
| Uifthenelse (cond, ifso, ifnot) ->
make_catch2
(fun shared ->
if_then_else
- (test_bool (transl env cond),
- exit_if_true env ifso nfail shared,
- exit_if_true env ifnot nfail shared))
+ (test_bool dbg (transl env cond),
+ exit_if_true dbg env ifso nfail shared,
+ exit_if_true dbg env ifnot nfail shared))
otherwise
| _ ->
- if_then_else(test_bool(transl env cond), Cexit (nfail, []), otherwise)
+ if_then_else(test_bool dbg (transl env cond),
+ Cexit (nfail, []), otherwise)
-and exit_if_false env cond otherwise nfail =
+and exit_if_false dbg env cond otherwise nfail =
match cond with
| Uconst (Uconst_ptr 0) -> Cexit (nfail,[])
| Uconst (Uconst_ptr 1) -> otherwise
| Uifthenelse (arg1, arg2, Uconst (Uconst_ptr 0))
| Uprim(Psequand, [arg1; arg2], _) ->
- exit_if_false env arg1 (exit_if_false env arg2 otherwise nfail) nfail
+ exit_if_false dbg env arg1
+ (exit_if_false dbg env arg2 otherwise nfail) nfail
| Uifthenelse (_, Uconst (Uconst_ptr 1), _)
| Uprim(Psequor, _, _) ->
begin match otherwise with
| Cexit (raise_num,[]) ->
- exit_if_true env cond raise_num (Cexit (nfail,[]))
+ exit_if_true dbg env cond raise_num (Cexit (nfail,[]))
| _ ->
let raise_num = next_raise_count () in
make_catch
raise_num
- (exit_if_true env cond raise_num (Cexit (nfail,[])))
+ (exit_if_true dbg env cond raise_num (Cexit (nfail,[])))
otherwise
end
| Uprim(Pnot, [arg], _) ->
- exit_if_true env arg nfail otherwise
+ exit_if_true dbg env arg nfail otherwise
| Uifthenelse (cond, ifso, ifnot) ->
make_catch2
(fun shared ->
if_then_else
- (test_bool (transl env cond),
- exit_if_false env ifso shared nfail,
- exit_if_false env ifnot shared nfail))
+ (test_bool dbg (transl env cond),
+ exit_if_false dbg env ifso shared nfail,
+ exit_if_false dbg env ifnot shared nfail))
otherwise
| _ ->
- if_then_else(test_bool(transl env cond), otherwise, Cexit (nfail, []))
+ if_then_else (test_bool dbg (transl env cond), otherwise,
+ Cexit (nfail, []))
-and transl_switch env arg index cases = match Array.length cases with
+and transl_switch _dbg env arg index cases = match Array.length cases with
| 0 -> fatal_error "Cmmgen.transl_switch"
| 1 -> transl env cases.(0)
| _ ->
(Array.of_list inters) store)
and transl_letrec env bindings cont =
+ let dbg = Debuginfo.none in
let bsz =
- List.map (fun (id, exp) -> (id, exp, expr_size Ident.empty exp)) bindings in
+ 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, None), [int_const sz]) in
+ Cop(Cextcall(prim, typ_val, true, None), [int_const sz], dbg) in
let rec init_blocks = function
| [] -> fill_nonrec bsz
| (id, _exp, RHS_block sz) :: rem ->
- Clet(id, op_alloc "caml_alloc_dummy" sz, init_blocks rem)
+ Clet(id, op_alloc "caml_alloc_dummy" sz,
+ init_blocks rem)
| (id, _exp, RHS_floatblock sz) :: rem ->
- Clet(id, op_alloc "caml_alloc_dummy_float" sz, init_blocks rem)
+ Clet(id, op_alloc "caml_alloc_dummy_float" sz,
+ init_blocks rem)
| (id, _exp, RHS_nonrec) :: rem ->
Clet (id, Cconst_int 0, init_blocks rem)
and fill_nonrec = function
| [] -> cont
| (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem ->
let op =
- Cop(Cextcall("caml_update_dummy", typ_void, false, Debuginfo.none,
- None),
- [Cvar id; transl env exp]) in
+ Cop(Cextcall("caml_update_dummy", typ_void, false, None),
+ [Cvar id; transl env exp], dbg) in
Csequence(op, fill_blocks rem)
| (_id, _exp, RHS_nonrec) :: rem ->
fill_blocks rem
else
f.body
in
+ let cmm_body =
+ let env = create_env ~environment_param:f.env in
+ if !Clflags.afl_instrument then
+ Afl_instrument.instrument_function (transl env body)
+ else
+ transl env body in
Cfunction {fun_name = f.label;
fun_args = List.map (fun id -> (id, typ_val)) f.params;
- fun_body = transl empty_env body;
+ fun_body = cmm_body;
fun_fast = !Clflags.optimize_for_speed;
- fun_dbg = f.dbg; }
+ fun_dbg = f.dbg}
(* Translate all function definitions *)
(Misc.map_end (fun f -> Cdouble f) fields cont)
| Uconst_closure(fundecls, lbl, fv) ->
assert(lbl = fst symb);
- constant_closures := (symb, fundecls, fv) :: !constant_closures;
+ add_cmm_constant (Const_closure (symb, fundecls, fv));
List.iter (fun f -> Queue.add f functions) fundecls;
cont
Csymbol_address f1.label ::
emit_others 4 remainder
+(* Emit constant blocks *)
+
+let emit_constant_table symb elems =
+ cdefine_symbol symb @
+ elems
+
(* Emit all structured constants *)
let emit_constants cont (constants:Clambda.preallocated_constant list) =
c:= Cdata(cst):: !c)
constants;
List.iter
- (fun (symb, fundecls, clos_vars) ->
- c := Cdata(emit_constant_closure symb fundecls clos_vars []) :: !c)
- !constant_closures;
- constant_closures := [];
+ (function
+ | Const_closure (symb, fundecls, clos_vars) ->
+ c := Cdata(emit_constant_closure symb fundecls clos_vars []) :: !c
+ | Const_table (symb, elems) ->
+ c := Cdata(emit_constant_table symb elems) :: !c)
+ !cmm_constants;
+ cmm_constants := [];
!c
let emit_all_constants cont =
(* Translate a compilation unit *)
let compunit (ulam, preallocated_blocks, constants) =
- let init_code = transl empty_env ulam in
+ let init_code =
+ if !Clflags.afl_instrument then
+ Afl_instrument.instrument_initialiser (transl empty_env ulam)
+ else
+ transl empty_env ulam in
let c1 = [Cfunction {fun_name = Compilenv.make_symbol (Some "entry");
fun_args = [];
fun_body = init_code; fun_fast = false;
}
*)
-let cache_public_method meths tag cache =
+let cache_public_method meths tag cache dbg =
let raise_num = next_raise_count () in
let li = Ident.create "li" and hi = Ident.create "hi"
and mi = Ident.create "mi" and tagged = Ident.create "tagged" in
Clet (
li, Cconst_int 3,
Clet (
- hi, Cop(Cload Word_int, [meths]),
+ hi, Cop(Cload (Word_int, Mutable), [meths], dbg),
Csequence(
- Ccatch
+ ccatch
(raise_num, [],
Cloop
(Clet(
mi,
Cop(Cor,
- [Cop(Clsr, [Cop(Caddi, [Cvar li; Cvar hi]); Cconst_int 1]);
- Cconst_int 1]),
+ [Cop(Clsr, [Cop(Caddi, [Cvar li; Cvar hi], dbg); Cconst_int 1],
+ dbg);
+ Cconst_int 1],
+ dbg),
Csequence(
Cifthenelse
(Cop (Ccmpi Clt,
[tag;
- Cop(Cload Word_int,
+ Cop(Cload (Word_int, Mutable),
[Cop(Cadda,
- [meths; lsl_const (Cvar mi) log2_size_addr])])]),
- Cassign(hi, Cop(Csubi, [Cvar mi; Cconst_int 2])),
+ [meths; lsl_const (Cvar mi) log2_size_addr dbg],
+ dbg)],
+ dbg)], dbg),
+ Cassign(hi, Cop(Csubi, [Cvar mi; Cconst_int 2], dbg)),
Cassign(li, Cvar mi)),
Cifthenelse
- (Cop(Ccmpi Cge, [Cvar li; Cvar hi]), Cexit (raise_num, []),
+ (Cop(Ccmpi Cge, [Cvar li; Cvar hi], dbg), Cexit (raise_num, []),
Ctuple [])))),
Ctuple []),
Clet (
- tagged, Cop(Cadda, [lsl_const (Cvar li) log2_size_addr;
- Cconst_int(1 - 3 * size_addr)]),
- Csequence(Cop (Cstore (Word_int, Assignment), [cache; Cvar tagged]),
- Cvar tagged)))))
+ tagged,
+ Cop(Cadda, [lsl_const (Cvar li) log2_size_addr dbg;
+ Cconst_int(1 - 3 * size_addr)], dbg),
+ Csequence(Cop (Cstore (Word_int, Assignment), [cache; Cvar tagged], dbg),
+ Cvar tagged)))))
(* Generate an application function:
(defun caml_applyN (a1 ... aN clos)
*)
let apply_function_body arity =
+ let dbg = Debuginfo.none in
let arg = Array.make arity (Ident.create "arg") in
for i = 1 to arity - 1 do arg.(i) <- Ident.create "arg" done;
let clos = Ident.create "clos" in
+ let env = empty_env in
let rec app_fun clos n =
if n = arity-1 then
- Cop(Capply(typ_val, Debuginfo.none),
- [get_field (Cvar clos) 0; Cvar arg.(n); Cvar clos])
+ Cop(Capply typ_val,
+ [get_field env (Cvar clos) 0 dbg; Cvar arg.(n); Cvar clos], dbg)
else begin
let newclos = Ident.create "clos" in
Clet(newclos,
- Cop(Capply(typ_val, Debuginfo.none),
- [get_field (Cvar clos) 0; Cvar arg.(n); Cvar clos]),
+ Cop(Capply typ_val,
+ [get_field env (Cvar clos) 0 dbg; Cvar arg.(n); Cvar clos], dbg),
app_fun newclos (n+1))
end in
let args = Array.to_list arg in
(args, clos,
if arity = 1 then app_fun clos 0 else
Cifthenelse(
- Cop(Ccmpi Ceq, [get_field (Cvar clos) 1; int_const arity]),
- Cop(Capply(typ_val, Debuginfo.none),
- get_field (Cvar clos) 2 :: List.map (fun s -> Cvar s) all_args),
+ Cop(Ccmpi Ceq, [get_field env (Cvar clos) 1 dbg; int_const arity], dbg),
+ Cop(Capply typ_val,
+ get_field env (Cvar clos) 2 dbg :: List.map (fun s -> Cvar s) all_args,
+ dbg),
app_fun clos 0))
let send_function arity =
+ let dbg = Debuginfo.none in
let (args, clos', body) = apply_function_body (1+arity) in
let cache = Ident.create "cache"
and obj = List.hd args
and tag = Ident.create "tag" in
+ let env = empty_env in
let clos =
let cache = Cvar cache and obj = Cvar obj and tag = Cvar tag in
let meths = Ident.create "meths" and cached = Ident.create "cached" in
let real = Ident.create "real" in
- let mask = get_field (Cvar meths) 1 in
+ let mask = get_field env (Cvar meths) 1 dbg in
let cached_pos = Cvar cached in
- let tag_pos = Cop(Cadda, [Cop (Cadda, [cached_pos; Cvar meths]);
- Cconst_int(3*size_addr-1)]) in
- let tag' = Cop(Cload Word_int, [tag_pos]) in
+ let tag_pos = Cop(Cadda, [Cop (Cadda, [cached_pos; Cvar meths], dbg);
+ Cconst_int(3*size_addr-1)], dbg) in
+ let tag' = Cop(Cload (Word_int, Mutable), [tag_pos], dbg) in
Clet (
- meths, Cop(Cload Word_val, [obj]),
+ meths, Cop(Cload (Word_val, Mutable), [obj], dbg),
Clet (
- cached, Cop(Cand, [Cop(Cload Word_int, [cache]); mask]),
+ cached,
+ Cop(Cand, [Cop(Cload (Word_int, Mutable), [cache], dbg); mask], dbg),
Clet (
real,
- Cifthenelse(Cop(Ccmpa Cne, [tag'; tag]),
- cache_public_method (Cvar meths) tag cache,
+ Cifthenelse(Cop(Ccmpa Cne, [tag'; tag], dbg),
+ cache_public_method (Cvar meths) tag cache dbg,
cached_pos),
- Cop(Cload Word_val, [Cop(Cadda, [Cop (Cadda, [Cvar real; Cvar meths]);
- Cconst_int(2*size_addr-1)])]))))
+ Cop(Cload (Word_val, Mutable),
+ [Cop(Cadda, [Cop (Cadda, [Cvar real; Cvar meths], dbg);
+ Cconst_int(2*size_addr-1)], dbg)], dbg))))
in
let body = Clet(clos', clos, body) in
+ let cache = cache in
let fun_args =
[obj, typ_val; tag, typ_int; cache, typ_val]
@ List.map (fun id -> (id, typ_val)) (List.tl args) in
+ let fun_name = "caml_send" ^ string_of_int arity in
Cfunction
- {fun_name = "caml_send" ^ string_of_int arity;
+ {fun_name;
fun_args = fun_args;
fun_body = body;
fun_fast = true;
let apply_function arity =
let (args, clos, body) = apply_function_body arity in
let all_args = args @ [clos] in
+ let fun_name = "caml_apply" ^ string_of_int arity in
Cfunction
- {fun_name = "caml_apply" ^ string_of_int arity;
+ {fun_name;
fun_args = List.map (fun id -> (id, typ_val)) all_args;
fun_body = body;
fun_fast = true;
- fun_dbg = Debuginfo.none }
+ fun_dbg = Debuginfo.none;
+ }
(* Generate tuplifying functions:
(defun caml_tuplifyN (arg clos)
(app clos.direct #0(arg) ... #N-1(arg) clos)) *)
let tuplify_function arity =
+ let dbg = Debuginfo.none in
let arg = Ident.create "arg" in
let clos = Ident.create "clos" in
+ let env = empty_env in
let rec access_components i =
if i >= arity
then []
- else get_field (Cvar arg) i :: access_components(i+1) in
+ else get_field env (Cvar arg) i dbg :: access_components(i+1) in
+ let fun_name = "caml_tuplify" ^ string_of_int arity in
Cfunction
- {fun_name = "caml_tuplify" ^ string_of_int arity;
+ {fun_name;
fun_args = [arg, typ_val; clos, typ_val];
fun_body =
- Cop(Capply(typ_val, Debuginfo.none),
- get_field (Cvar clos) 2 :: access_components 0 @ [Cvar clos]);
+ Cop(Capply typ_val,
+ get_field env (Cvar clos) 2 dbg :: access_components 0 @ [Cvar clos],
+ dbg);
fun_fast = true;
- fun_dbg = Debuginfo.none }
+ fun_dbg = Debuginfo.none;
+ }
(* Generate currying functions:
(defun caml_curryN (arg clos)
let max_arity_optimized = 15
let final_curry_function arity =
+ let dbg = Debuginfo.none in
let last_arg = Ident.create "arg" in
let last_clos = Ident.create "clos" in
+ let env = empty_env in
let rec curry_fun args clos n =
if n = 0 then
- Cop(Capply(typ_val, Debuginfo.none),
- get_field (Cvar clos) 2 ::
- args @ [Cvar last_arg; Cvar clos])
+ Cop(Capply typ_val,
+ get_field env (Cvar clos) 2 dbg ::
+ args @ [Cvar last_arg; Cvar clos],
+ dbg)
else
if n = arity - 1 || arity > max_arity_optimized then
begin
let newclos = Ident.create "clos" in
Clet(newclos,
- get_field (Cvar clos) 3,
- curry_fun (get_field (Cvar clos) 2 :: args) newclos (n-1))
+ get_field env (Cvar clos) 3 dbg,
+ curry_fun (get_field env (Cvar clos) 2 dbg :: args) newclos (n-1))
end else
begin
let newclos = Ident.create "clos" in
Clet(newclos,
- get_field (Cvar clos) 4,
- curry_fun (get_field (Cvar clos) 3 :: args) newclos (n-1))
+ get_field env (Cvar clos) 4 dbg,
+ curry_fun (get_field env (Cvar clos) 3 dbg :: args) newclos (n-1))
end in
Cfunction
{fun_name = "caml_curry" ^ string_of_int arity ^
fun_dbg = Debuginfo.none }
let rec intermediate_curry_functions arity num =
+ let dbg = Debuginfo.none in
+ let env = empty_env in
if num = arity - 1 then
[final_curry_function arity]
else begin
fun_args = [arg, typ_val; clos, typ_val];
fun_body =
if arity - num > 2 && arity <= max_arity_optimized then
- Cop(Calloc Debuginfo.none,
+ Cop(Calloc,
[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])
+ Cvar arg; Cvar clos],
+ dbg)
else
- 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]);
+ Cop(Calloc,
+ [alloc_closure_header 4 Debuginfo.none;
+ Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1));
+ int_const 1; Cvar arg; Cvar clos],
+ dbg);
fun_fast = true;
fun_dbg = Debuginfo.none }
::
let direct_args = iter (num+2) in
let rec iter i args clos =
if i = 0 then
- Cop(Capply(typ_val, Debuginfo.none),
- (get_field (Cvar clos) 2) :: args @ [Cvar clos])
+ Cop(Capply typ_val,
+ (get_field env (Cvar clos) 2 dbg) :: args @ [Cvar clos],
+ dbg)
else
let newclos = Ident.create "clos" in
Clet(newclos,
- get_field (Cvar clos) 4,
- iter (i-1) (get_field (Cvar clos) 3 :: args) newclos)
+ get_field env (Cvar clos) 4 dbg,
+ iter (i-1) (get_field env (Cvar clos) 3 dbg :: args) newclos)
in
let cf =
Cfunction
(* Generate the entry point *)
let entry_point namelist =
+ (* CR mshinwell: review all of these "None"s. We should be able to at
+ least have filenames for these. *)
+ let dbg = Debuginfo.none in
let incr_global_inited =
Cop(Cstore (Word_int, Assignment),
[Cconst_symbol "caml_globals_inited";
- Cop(Caddi, [Cop(Cload Word_int, [Cconst_symbol "caml_globals_inited"]);
- Cconst_int 1])]) in
+ Cop(Caddi, [Cop(Cload (Word_int, Mutable),
+ [Cconst_symbol "caml_globals_inited"], dbg);
+ Cconst_int 1], dbg)], dbg) in
let body =
List.fold_right
(fun name next ->
let entry_sym = Compilenv.make_symbol ~unitname:name (Some "entry") in
- Csequence(Cop(Capply(typ_void, Debuginfo.none),
- [Cconst_symbol entry_sym]),
+ Csequence(Cop(Capply typ_void,
+ [Cconst_symbol entry_sym], dbg),
Csequence(incr_global_inited, next)))
namelist (Cconst_int 1) in
Cfunction {fun_name = "caml_program";
let newbody = combine_restart body in
(instr_cons (Iloop(newbody)) i.arg i.res i.next,
allocated_size allocstate)
- | Icatch(io, body, handler) ->
+ | Icatch(rec_flag, handlers, body) ->
let (newbody, sz) = combine body allocstate in
- let newhandler = combine_restart handler in
+ let newhandlers =
+ List.map (fun (io, handler) -> io, combine_restart handler) handlers in
let newnext = combine_restart i.next in
- (instr_cons (Icatch(io, newbody, newhandler)) i.arg i.res newnext, sz)
+ (instr_cons (Icatch(rec_flag, newhandlers, newbody))
+ i.arg i.res newnext, sz)
| Itrywith(body, handler) ->
let (newbody, sz) = combine body allocstate in
let newhandler = combine_restart handler in
let imported_sets_of_closures_table =
(Set_of_closures_id.Tbl.create 10
- : Flambda.function_declarations Set_of_closures_id.Tbl.t)
+ : Flambda.function_declarations option Set_of_closures_id.Tbl.t)
let sourcefile = ref None
current_unit.ui_curry_fun <- [];
current_unit.ui_apply_fun <- [];
current_unit.ui_send_fun <- [];
- current_unit.ui_force_link <- false;
+ current_unit.ui_force_link <- !Clflags.link_everything;
Hashtbl.clear exported_constants;
structured_constants := structured_constants_empty;
current_unit.ui_export_info <- default_ui_export_info;
improvement feature.
*)
val imported_sets_of_closures_table
- : Flambda.function_declarations Set_of_closures_id.Tbl.t
+ : Flambda.function_declarations option Set_of_closures_id.Tbl.t
(* flambda-only *)
val reset: ?packname:string -> source_provenance:Timings.source_provenance ->
let (body', _) = deadcode body in
let (s, _) = deadcode i.next in
({i with desc = Iloop body'; next = s}, i.live)
- | Icatch(nfail, body, handler) ->
+ | Icatch(rec_flag, handlers, body) ->
let (body', _) = deadcode body in
- let (handler', _) = deadcode handler in
+ let handlers' =
+ List.map (fun (nfail, handler) ->
+ let (handler', _) = deadcode handler in
+ nfail, handler')
+ handlers
+ in
let (s, _) = deadcode i.next in
- ({i with desc = Icatch(nfail, body', handler'); next = s}, i.live)
- | Iexit _ ->
+ ({i with desc = Icatch(rec_flag, handlers', body'); next = s}, i.live)
+ | Iexit _nfail ->
(i, i.live)
| Itrywith(body, handler) ->
let (body', _) = deadcode body in
let frame_descriptors = ref([] : frame_descr list)
+let record_frame_descr ~label ~frame_size ~live_offset ~raise_frame debuginfo =
+ frame_descriptors :=
+ { fd_lbl = label;
+ fd_frame_size = frame_size;
+ fd_live_offset = List.sort_uniq (-) live_offset;
+ fd_raise = raise_frame;
+ fd_debuginfo = debuginfo } :: !frame_descriptors
+
type emit_frame_actions =
{ efa_code_label: int -> unit;
efa_data_label: int -> unit;
Hashtbl.add filenames name lbl;
lbl
in
- let debuginfos = Hashtbl.create 7 in
+ let module Label_table =
+ Hashtbl.Make (struct
+ type t = bool * Debuginfo.t
+
+ let equal ((rs1 : bool), dbg1) (rs2, dbg2) =
+ rs1 = rs2 && Debuginfo.compare dbg1 dbg2 = 0
+
+ let hash (rs, dbg) =
+ Hashtbl.hash (rs, Debuginfo.hash dbg)
+ end)
+ in
+ let debuginfos = Label_table.create 7 in
let rec label_debuginfos rs rdbg =
let key = (rs, rdbg) in
- try fst (Hashtbl.find debuginfos key)
+ try fst (Label_table.find debuginfos key)
with Not_found ->
let lbl = Cmm.new_label () in
let next =
| _ :: [] -> None
| _ :: ((_ :: _) as rdbg') -> Some (label_debuginfos false rdbg')
in
- Hashtbl.add debuginfos key (lbl, next);
+ Label_table.add debuginfos key (lbl, next);
lbl
in
let emit_debuginfo_label rs rdbg =
in
a.efa_word (List.length !frame_descriptors);
List.iter emit_frame !frame_descriptors;
- Hashtbl.iter emit_debuginfo debuginfos;
+ Label_table.iter emit_debuginfo debuginfos;
Hashtbl.iter emit_filename filenames;
frame_descriptors := []
(file_num:int -> file_name:string -> unit) ->
(file_num:int -> line:int -> col:int -> unit) -> unit
-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
+val record_frame_descr :
+ label:int -> (* Return address *)
+ frame_size:int -> (* Size of stack frame *)
+ live_offset:int list -> (* Offsets/regs of live addresses *)
+ raise_frame:bool -> (* Is frame for a raise? *)
+ Debuginfo.t -> (* Location, if any *)
+ unit
type emit_frame_actions =
{ efa_code_label: int -> unit;
Set_of_closures_id.Map.disjoint_union t1.sets_of_closures
t2.sets_of_closures;
closures = Closure_id.Map.disjoint_union t1.closures t2.closures;
- symbol_id = Symbol.Map.disjoint_union t1.symbol_id t2.symbol_id;
+ symbol_id = Symbol.Map.disjoint_union ~print:Export_id.print t1.symbol_id t2.symbol_id;
offset_fun = Closure_id.Map.disjoint_union
~eq:int_eq t1.offset_fun t2.offset_fun;
offset_fv = Var_within_closure.Map.disjoint_union
t2.constant_sets_of_closures;
invariant_params =
Set_of_closures_id.Map.disjoint_union
+ ~print:(Variable.Map.print Variable.Set.print)
~eq:(Variable.Map.equal Variable.Set.equal)
t1.invariant_params t2.invariant_params;
}
in
Export_id.Map.fold add_map map Compilation_unit.Map.empty
-let print_approx ppf (t : t) =
+let print_approx ppf ((t,root_symbols) : t * Symbol.t list) =
let values = t.values in
let fprintf = Format.fprintf in
let printed = ref Export_id.Set.empty in
and print_fields ppf fields =
Array.iter (fun approx -> fprintf ppf "%a@ " print_approx approx) fields
and print_set_of_closures ppf
- { set_of_closures_id; bound_vars; aliased_symbol } =
+ { set_of_closures_id; bound_vars; aliased_symbol; results } =
if Set_of_closures_id.Set.mem set_of_closures_id !printed_set_of_closures
then fprintf ppf "%a" Set_of_closures_id.print set_of_closures_id
else begin
| Some symbol ->
Format.fprintf ppf "@ (alias: %a)" Symbol.print symbol
in
- fprintf ppf "{%a: %a%a}"
+ fprintf ppf "{%a: %a%a => %a}"
Set_of_closures_id.print set_of_closures_id
print_binding bound_vars
print_alias aliased_symbol
+ (Closure_id.Map.print print_approx) results
end
and print_binding ppf bound_vars =
Var_within_closure.Map.iter (fun clos_id approx ->
print_recorded_symbols ();
end
in
+ List.iter (fun s -> Queue.push s symbols_to_print) root_symbols;
fprintf ppf "@[<hov 2>Globals:@ ";
fprintf ppf "@]@ @[<hov 2>Symbols:@ ";
print_recorded_symbols ();
Var_within_closure.print vid off) t.offset_fv;
Format.fprintf ppf "@]@ "
-let print_all ppf (t : t) =
+let print_functions ppf (t : t) =
+ Set_of_closures_id.Map.print Flambda.print_function_declarations ppf
+ t.sets_of_closures
+
+let print_all ppf ((t, root_symbols) : t * Symbol.t list) =
let fprintf = Format.fprintf in
fprintf ppf "approxs@ %a@.@."
- print_approx t;
+ print_approx (t, root_symbols);
fprintf ppf "functions@ %a@.@."
- (Set_of_closures_id.Map.print Flambda.print_function_declarations)
- t.sets_of_closures
+ print_functions t
(**/**)
(* Debug printing functions. *)
-val print_approx : Format.formatter -> t -> unit
+val print_approx : Format.formatter -> t * Symbol.t list -> unit
+val print_functions : Format.formatter -> t -> unit
val print_offsets : Format.formatter -> t -> unit
-val print_all : Format.formatter -> t -> unit
+val print_all : Format.formatter -> t * Symbol.t list -> unit
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
let rename_id_state = Export_id.Tbl.create 100
+let rename_set_of_closures_id_state = Set_of_closures_id.Tbl.create 10
+let imported_function_declarations_table =
+ (Set_of_closures_id.Tbl.create 10
+ : Flambda.function_declarations Set_of_closures_id.Tbl.t)
(* Rename export identifiers' compilation units to denote that they now
live within a pack. *)
| Value_id eid -> Value_id (import_eid_for_pack units pack eid)
| Value_unknown -> Value_unknown
+let import_set_of_closures_id_for_pack units pack
+ (set_of_closures_id : Set_of_closures_id.t)
+ : Set_of_closures_id.t =
+ let compilation_unit =
+ Set_of_closures_id.get_compilation_unit set_of_closures_id
+ in
+ if Compilation_unit.Set.mem compilation_unit units then
+ Set_of_closures_id.Tbl.memoize
+ rename_set_of_closures_id_state
+ (fun _ ->
+ Set_of_closures_id.create
+ ?name:(Set_of_closures_id.name set_of_closures_id)
+ pack)
+ set_of_closures_id
+ else set_of_closures_id
+
+let import_set_of_closures_origin_for_pack units pack
+ (set_of_closures_origin : Set_of_closures_origin.t)
+ : Set_of_closures_origin.t =
+ Set_of_closures_origin.rename
+ (import_set_of_closures_id_for_pack units pack)
+ set_of_closures_origin
+
let import_set_of_closures units pack
(set_of_closures : Export_info.value_set_of_closures)
: Export_info.value_set_of_closures =
- { set_of_closures_id = set_of_closures.set_of_closures_id;
+ { set_of_closures_id =
+ import_set_of_closures_id_for_pack units pack
+ set_of_closures.set_of_closures_id;
bound_vars =
Var_within_closure.Map.map (import_approx_for_pack units pack)
set_of_closures.bound_vars;
| Value_set_of_closures set_of_closures ->
Value_set_of_closures (import_set_of_closures units pack set_of_closures)
-let import_code_for_pack units pack expr =
+let rec import_code_for_pack units pack expr =
Flambda_iterators.map_named (function
| Symbol sym -> Symbol (import_symbol_for_pack units pack sym)
| Read_symbol_field (sym, field) ->
Read_symbol_field (import_symbol_for_pack units pack sym, field)
+ | Set_of_closures set_of_closures ->
+ let set_of_closures =
+ Flambda.create_set_of_closures
+ ~free_vars:set_of_closures.free_vars
+ ~specialised_args:set_of_closures.specialised_args
+ ~direct_call_surrogates:set_of_closures.direct_call_surrogates
+ ~function_decls:
+ (import_function_declarations_for_pack units pack
+ set_of_closures.function_decls)
+ in
+ Set_of_closures set_of_closures
| e -> e)
expr
-let import_function_declarations_for_pack units pack
+and import_function_declarations_for_pack_aux units pack
(function_decls : Flambda.function_declarations) =
let funs =
Variable.Map.map (fun (function_decl : Flambda.function_declaration) ->
~is_a_functor:function_decl.is_a_functor)
function_decls.funs
in
- Flambda.update_function_declarations function_decls ~funs
+ Flambda.import_function_declarations_for_pack
+ (Flambda.update_function_declarations function_decls ~funs)
+ (import_set_of_closures_id_for_pack units pack)
+ (import_set_of_closures_origin_for_pack units pack)
+
+and import_function_declarations_for_pack units pack
+ (function_decls:Flambda.function_declarations) =
+ let original_set_of_closures_id = function_decls.set_of_closures_id in
+ try
+ Set_of_closures_id.Tbl.find imported_function_declarations_table
+ original_set_of_closures_id
+ with Not_found ->
+ let function_decls =
+ import_function_declarations_for_pack_aux units pack function_decls
+ in
+ Set_of_closures_id.Tbl.add
+ imported_function_declarations_table
+ original_set_of_closures_id
+ function_decls;
+ function_decls
let import_eidmap_for_pack units pack f map =
Export_info.nest_eid_map
let import_descr = import_descr_for_pack pack_units pack in
let import_eid = import_eid_for_pack pack_units pack in
let import_eidmap f map = import_eidmap_for_pack pack_units pack f map in
+ let import_set_of_closures_id =
+ import_set_of_closures_id_for_pack pack_units pack
+ in
+ let import_function_declarations =
+ import_function_declarations_for_pack pack_units pack
+ in
let sets_of_closures =
- Set_of_closures_id.Map.map
- (import_function_declarations_for_pack pack_units pack)
- exp.sets_of_closures
+ Set_of_closures_id.Map.map_keys import_set_of_closures_id
+ (Set_of_closures_id.Map.map
+ import_function_declarations
+ exp.sets_of_closures)
in
Export_info.create ~sets_of_closures
~closures:(Flambda_utils.make_closure_map' sets_of_closures)
~values:(import_eidmap import_descr exp.values)
~symbol_id:(Symbol.Map.map_keys import_sym
(Symbol.Map.map import_eid exp.symbol_id))
- ~constant_sets_of_closures:exp.constant_sets_of_closures
- ~invariant_params:exp.invariant_params
+ ~constant_sets_of_closures:
+ (Set_of_closures_id.Set.map import_set_of_closures_id
+ exp.constant_sets_of_closures)
+ ~invariant_params:
+ (Set_of_closures_id.Map.map_keys import_set_of_closures_id
+ exp.invariant_params)
-let clear_import_state () = Export_id.Tbl.clear rename_id_state
+let clear_import_state () =
+ Set_of_closures_id.Tbl.clear imported_function_declarations_table;
+ Set_of_closures_id.Tbl.clear rename_set_of_closures_id_state;
+ Export_id.Tbl.clear rename_id_state
params = params @ [env_var];
body = to_clambda t env_body function_decl.body;
dbg = function_decl.dbg;
+ env = Some env_var;
}
in
let funs = List.map to_clambda_function all_functions in
params;
body = to_clambda t env_body function_decl.body;
dbg = function_decl.dbg;
+ env = None;
}
in
let ufunct = List.map to_clambda_function functions in
let build_setfield (index, field) : Clambda.ulambda =
(* Note that this will never cause a write barrier hit, owing to
the [Initialization]. *)
- Uprim (Psetfield (index, Pointer, Initialization),
+ Uprim (Psetfield (index, Pointer, Root_initialization),
[to_clambda_symbol env symbol; field],
Debuginfo.none)
in
Misc.fatal_error ("bad GC root " ^ Reg.name r)
| _ -> ())
live;
- frame_descriptors :=
- { fd_lbl = lbl;
- fd_frame_size = frame_size();
- fd_live_offset = !live_offset;
- fd_raise = raise_;
- fd_debuginfo = dbg } :: !frame_descriptors;
+ record_frame_descr ~label:lbl ~frame_size:(frame_size())
+ ~live_offset:!live_offset ~raise_frame:raise_ dbg;
lbl
let record_frame ?label live raise_ dbg =
match exp with
Cconst_symbol s ->
(Asymbol s, 0)
- | Cop((Caddi | Caddv | Cadda), [arg; Cconst_int m]) ->
+ | Cop((Caddi | Caddv | Cadda), [arg; Cconst_int m], _) ->
let (a, n) = select_addr arg in (a, n + m)
- | Cop(Csubi, [arg; Cconst_int m]) ->
+ | Cop(Csubi, [arg; Cconst_int m], _) ->
let (a, n) = select_addr arg in (a, n - m)
- | Cop((Caddi | Caddv | Cadda), [Cconst_int m; arg]) ->
+ | Cop((Caddi | Caddv | Cadda), [Cconst_int m; arg], _) ->
let (a, n) = select_addr arg in (a, n + m)
- | Cop(Clsl, [arg; Cconst_int(1|2|3 as shift)]) ->
+ | Cop(Clsl, [arg; Cconst_int(1|2|3 as shift)], _) ->
begin match select_addr arg with
(Alinear e, n) -> (Ascale(e, 1 lsl shift), n lsl shift)
| _ -> (Alinear exp, 0)
end
- | Cop(Cmuli, [arg; Cconst_int(2|4|8 as mult)]) ->
+ | Cop(Cmuli, [arg; Cconst_int(2|4|8 as mult)], _) ->
begin match select_addr arg with
(Alinear e, n) -> (Ascale(e, mult), n * mult)
| _ -> (Alinear exp, 0)
end
- | Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg]) ->
+ | Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg], _) ->
begin match select_addr arg with
(Alinear e, n) -> (Ascale(e, mult), n * mult)
| _ -> (Alinear exp, 0)
end
- | Cop((Caddi | Cadda | Caddv), [arg1; arg2]) ->
+ | Cop((Caddi | Cadda | Caddv), [arg1; arg2], _) ->
begin match (select_addr arg1, select_addr arg2) with
((Alinear e1, n1), (Alinear e2, n2)) ->
(Aadd(e1, e2), n1 + n2)
| arg ->
(Alinear arg, 0)
-(* C functions to be turned into Ifloatspecial instructions if -ffast-math *)
-
+(* C functions to be turned into Ifloatspecial instructions if -ffast-math.
+ If you update this list, you may need to update [is_simple_expr] and/or
+ [effects_of], below. *)
let inline_float_ops =
["atan"; "atan2"; "cos"; "log"; "log10"; "sin"; "sqrt"; "tan"]
(Ershov's algorithm) *)
let rec float_needs = function
- Cop((Cnegf | Cabsf), [arg]) ->
+ Cop((Cnegf | Cabsf), [arg], _) ->
float_needs arg
- | Cop((Caddf | Csubf | Cmulf | Cdivf), [arg1; arg2]) ->
+ | Cop((Caddf | Csubf | Cmulf | Cdivf), [arg1; arg2], _) ->
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, _label), args)
+ | Cop(Cextcall(fn, _ty_res, _alloc, _label), args, _dbg)
when !fast_math && List.mem fn inline_float_ops ->
begin match args with
[arg] -> float_needs arg
method! is_simple_expr e =
match e with
- | Cop(Cextcall(fn, _, _, _, _), args)
+ | Cop(Cextcall(fn, _, _alloc, _), 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! effects_of e =
+ match e with
+ | Cop(Cextcall(fn, _, _, _), args, _)
+ when !fast_math && List.mem fn inline_float_ops ->
+ Selectgen.Effect_and_coeffect.join_list_map args self#effects_of
+ | _ ->
+ super#effects_of e
+
method select_addressing _chunk exp =
match select_addr exp with
(Asymbol s, d) ->
| _ ->
super#select_store is_assign addr exp
-method! select_operation op args =
+method! select_operation op args dbg =
match op with
(* Recognize the LEA instruction *)
Caddi | Caddv | Cadda | Csubi ->
- begin match self#select_addressing Word_int (Cop(op, args)) with
+ begin match self#select_addressing Word_int (Cop(op, args, dbg)) with
(Iindexed _, _)
- | (Iindexed2 0, _) -> super#select_operation op args
+ | (Iindexed2 0, _) -> super#select_operation op args dbg
| (addr, arg) -> (Ispecific(Ilea addr), [arg])
end
(* Recognize float arithmetic with memory.
(* Recognize store instructions *)
| Cstore ((Word_int | Word_val) as chunk, _) ->
begin match args with
- [loc; Cop(Caddi, [Cop(Cload _, [loc']); Cconst_int n])]
+ [loc; Cop(Caddi, [Cop(Cload _, [loc'], _); Cconst_int n], _)]
when loc = loc' ->
let (addr, arg) = self#select_addressing chunk loc in
(Ispecific(Ioffset_loc(n, addr)), [arg])
| _ ->
- super#select_operation op args
+ super#select_operation op args dbg
end
(* Recognize inlined floating point operations *)
- | Cextcall(fn, _ty_res, false, _dbg, _label)
+ | Cextcall(fn, _ty_res, false, _label)
when !fast_math && List.mem fn inline_float_ops ->
(Ispecific(Ifloatspecial fn), args)
(* i386 does not support immediate operands for multiply high signed *)
| Cmulhi ->
(Iintop Imulh, args)
(* Default *)
- | _ -> super#select_operation op args
+ | _ -> super#select_operation op args dbg
(* Recognize float arithmetic with mem *)
method select_floatarith regular_op reversed_op mem_op mem_rev_op args =
match args with
- [arg1; Cop(Cload chunk, [loc2])] ->
+ [arg1; Cop(Cload (chunk, _), [loc2], _)] ->
let (addr, arg2) = self#select_addressing chunk loc2 in
(Ispecific(Ifloatarithmem(chunk_double chunk, mem_op, addr)),
[arg1; arg2])
- | [Cop(Cload chunk, [loc1]); arg2] ->
+ | [Cop(Cload (chunk, _), [loc1], _); arg2] ->
let (addr, arg1) = self#select_addressing chunk loc1 in
(Ispecific(Ifloatarithmem(chunk_double chunk, mem_rev_op, addr)),
[arg2; arg1])
| Cconst_pointer n -> (Ispecific(Ipush_int(Nativeint.of_int n)), Ctuple [])
| Cconst_natpointer n -> (Ispecific(Ipush_int n), Ctuple [])
| Cconst_symbol s -> (Ispecific(Ipush_symbol s), Ctuple [])
- | Cop(Cload (Word_int | Word_val as chunk), [loc]) ->
+ | Cop(Cload ((Word_int | Word_val as chunk), _), [loc], _) ->
let (addr, arg) = self#select_addressing chunk loc in
(Ispecific(Ipush_load addr), arg)
- | Cop(Cload Double_u, [loc]) ->
+ | Cop(Cload (Double_u, _), [loc], _) ->
let (addr, arg) = self#select_addressing Double_u loc in
(Ispecific(Ipush_load_float addr), arg)
| _ -> (Ispecific(Ipush), exp)
Flambda.update_function_declarations clos ~funs
in
let aux set_of_closures_id =
+ ignore (Compilenv.approx_for_global
+ (Set_of_closures_id.get_compilation_unit set_of_closures_id));
let ex_info = Compilenv.approx_env () in
let function_declarations =
try
- Set_of_closures_id.Map.find set_of_closures_id
- ex_info.sets_of_closures
+ Some (Set_of_closures_id.Map.find set_of_closures_id
+ ex_info.sets_of_closures)
with Not_found ->
- Misc.fatal_errorf "[functions] does not map set of closures ID %a. \
- ex_info = %a"
- Set_of_closures_id.print set_of_closures_id
- Export_info.print_all ex_info
+ None
in
- import_function_declarations function_declarations
+ match function_declarations with
+ | None -> None
+ | Some function_declarations ->
+ Some (import_function_declarations function_declarations)
in
Set_of_closures_id.Tbl.memoize Compilenv.imported_sets_of_closures_table aux
ignore (Compilenv.approx_for_global (Export_id.get_compilation_unit ex));
let ex_info = Compilenv.approx_env () in
let import_value_set_of_closures ~set_of_closures_id ~bound_vars
- ~(ex_info : Export_info.t) ~what : A.value_set_of_closures =
+ ~(ex_info : Export_info.t) ~what : A.value_set_of_closures option =
let bound_vars = Var_within_closure.Map.map import_approx bound_vars in
match
Set_of_closures_id.Map.find set_of_closures_id ex_info.invariant_params
Export_id.print ex
what
| invariant_params ->
- A.create_value_set_of_closures
- ~function_decls:(import_set_of_closures set_of_closures_id)
- ~bound_vars
- ~invariant_params:(lazy invariant_params)
- ~specialised_args:Variable.Map.empty
- ~freshening:Freshening.Project_var.empty
- ~direct_call_surrogates:Closure_id.Map.empty
+ match import_set_of_closures set_of_closures_id with
+ | None -> None
+ | Some function_decls ->
+ Some (A.create_value_set_of_closures
+ ~function_decls
+ ~bound_vars
+ ~invariant_params:(lazy invariant_params)
+ ~specialised_args:Variable.Map.empty
+ ~freshening:Freshening.Project_var.empty
+ ~direct_call_surrogates:Closure_id.Map.empty)
in
match Export_info.find_description ex_info ex with
| exception Not_found -> A.value_unknown Other
import_value_set_of_closures ~set_of_closures_id ~bound_vars ~ex_info
~what:(Format.asprintf "Value_closure %a" Closure_id.print closure_id)
in
- A.value_closure ?set_of_closures_symbol:aliased_symbol
- value_set_of_closures closure_id
+ begin match value_set_of_closures with
+ | None -> A.value_unresolved (Set_of_closures_id set_of_closures_id)
+ | Some value_set_of_closures ->
+ A.value_closure ?set_of_closures_symbol:aliased_symbol
+ value_set_of_closures closure_id
+ end
| Value_set_of_closures { set_of_closures_id; bound_vars; aliased_symbol } ->
let value_set_of_closures =
import_value_set_of_closures ~set_of_closures_id ~bound_vars ~ex_info
~what:"Value_set_of_closures"
in
- let approx = A.value_set_of_closures value_set_of_closures in
- match aliased_symbol with
- | None -> approx
- | Some symbol -> A.augment_with_symbol approx symbol
+ match value_set_of_closures with
+ | None ->
+ A.value_unresolved (Set_of_closures_id set_of_closures_id)
+ | Some value_set_of_closures ->
+ let approx = A.value_set_of_closures value_set_of_closures in
+ match aliased_symbol with
+ | None -> approx
+ | Some symbol -> A.augment_with_symbol approx symbol
and import_approx (ap : Export_info.approx) =
match ap with
match Symbol.Map.find sym symbol_id_map with
| approx -> A.augment_with_symbol (import_ex approx) sym
| exception Not_found ->
- A.value_unresolved sym
+ A.value_unresolved (Symbol sym)
(* Note for code reviewers: Observe that [really_import] iterates until
the approximation description is fully resolved (or a necessary .cmx
interf i.next
| Iloop body ->
interf body; interf i.next
- | Icatch(_, body, handler) ->
- interf body; interf handler; interf i.next
+ | Icatch(_rec_flag, handlers, body) ->
+ interf body;
+ List.iter (fun (_, handler) -> interf handler) handlers;
+ interf i.next
| Iexit _ ->
()
| Itrywith(body, handler) ->
(* Avoid overflow of weight and spill_cost *)
prefer (if weight < 1000 then 8 * weight else weight) body;
prefer weight i.next
- | Icatch(_, body, handler) ->
- prefer weight body; prefer weight handler; prefer weight i.next
+ | Icatch(rec_flag, handlers, body) ->
+ prefer weight body;
+ List.iter (fun (_nfail, handler) ->
+ let weight =
+ match rec_flag with
+ | Cmm.Recursive ->
+ (* Avoid overflow of weight and spill_cost *)
+ if weight < 1000 then 8 * weight else weight
+ | Cmm.Nonrecursive ->
+ weight in
+ prefer weight handler) handlers;
+ prefer weight i.next
| Iexit _ ->
()
| Itrywith(body, handler) ->
let n1 = linear i.Mach.next n in
let n2 = linear body (cons_instr (Lbranch lbl_head) n1) in
cons_instr (Llabel lbl_head) n2
- | Icatch(io, body, handler) ->
+ | Icatch(_rec_flag, handlers, body) ->
let (lbl_end, n1) = get_label(linear i.Mach.next n) in
- let (lbl_handler, n2) = get_label(linear handler n1) in
- exit_label := (io, (lbl_handler, !try_depth)) :: !exit_label ;
+ (* CR mshinwell for pchambart:
+ 1. rename "io"
+ 2. Make sure the test cases cover the "Iend" cases too *)
+ let labels_at_entry_to_handlers = List.map (fun (_nfail, handler) ->
+ match handler.Mach.desc with
+ | Iend -> lbl_end
+ | _ -> Cmm.new_label ())
+ handlers in
+ let exit_label_add = List.map2
+ (fun (nfail, _) lbl -> (nfail, (lbl, !try_depth)))
+ handlers labels_at_entry_to_handlers in
+ let previous_exit_label = !exit_label in
+ exit_label := exit_label_add @ !exit_label;
+ let n2 = List.fold_left2 (fun n (_nfail, handler) lbl_handler ->
+ match handler.Mach.desc with
+ | Iend -> n
+ | _ -> cons_instr (Llabel lbl_handler) (linear handler n))
+ n1 handlers labels_at_entry_to_handlers
+ in
let n3 = linear body (add_branch lbl_end n2) in
- exit_label := List.tl !exit_label;
+ exit_label := previous_exit_label;
n3
| Iexit nfail ->
let lbl, t = find_exit_label_try_depth nfail in
end;
i.live <- !at_top;
!at_top
- | Icatch(nfail, body, handler) ->
+ | Icatch(rec_flag, handlers, body) ->
let at_join = live i.next finally in
- let before_handler = live handler at_join in
- let before_body =
- live_at_exit := (nfail,before_handler) :: !live_at_exit ;
- let before_body = live body at_join in
- live_at_exit := List.tl !live_at_exit ;
- before_body in
+ let aux (nfail,handler) (nfail', before_handler) =
+ assert(nfail = nfail');
+ let before_handler' = live handler at_join in
+ nfail, Reg.Set.union before_handler before_handler'
+ in
+ let aux_equal (nfail, before_handler) (nfail', before_handler') =
+ assert(nfail = nfail');
+ Reg.Set.equal before_handler before_handler'
+ in
+ let live_at_exit_before = !live_at_exit in
+ let live_at_exit_add before_handlers =
+ List.map (fun (nfail, before_handler) ->
+ (nfail, before_handler))
+ before_handlers
+ in
+ let rec fixpoint before_handlers =
+ let live_at_exit_add = live_at_exit_add before_handlers in
+ live_at_exit := live_at_exit_add @ !live_at_exit;
+ let before_handlers' = List.map2 aux handlers before_handlers in
+ live_at_exit := live_at_exit_before;
+ match rec_flag with
+ | Cmm.Nonrecursive ->
+ before_handlers'
+ | Cmm.Recursive ->
+ if List.for_all2 aux_equal before_handlers before_handlers'
+ then before_handlers'
+ else fixpoint before_handlers'
+ in
+ let init_state =
+ List.map (fun (nfail, _handler) -> nfail, Reg.Set.empty) handlers
+ in
+ let before_handler = fixpoint init_state in
+ (* We could use handler.live instead of Reg.Set.empty as the initial
+ value but we would need to clean the live field before doing the
+ analysis (to remove remnants of previous passes). *)
+ live_at_exit := (live_at_exit_add before_handler) @ !live_at_exit;
+ let before_body = live body at_join in
+ live_at_exit := live_at_exit_before;
i.live <- before_body;
before_body
| Iexit nfail ->
| Iifthenelse of test * instruction * instruction
| Iswitch of int array * instruction array
| Iloop of instruction
- | Icatch of int * instruction * instruction
+ | Icatch of Cmm.rec_flag * (int * instruction) list * instruction
| Iexit of int
| Itrywith of instruction * instruction
| Iraise of Cmm.raise_kind
instr_iter f i.next
| Iloop(body) ->
instr_iter f body; instr_iter f i.next
- | Icatch(_, body, handler) ->
- instr_iter f body; instr_iter f handler; instr_iter f i.next
+ | Icatch(_, handlers, body) ->
+ instr_iter f body;
+ List.iter (fun (_n, handler) -> instr_iter f handler) handlers;
+ instr_iter f i.next
| Iexit _ -> ()
| Itrywith(body, handler) ->
instr_iter f body; instr_iter f handler; instr_iter f i.next
| Iifthenelse of test * instruction * instruction
| Iswitch of int array * instruction array
| Iloop of instruction
- | Icatch of int * instruction * instruction
+ | Icatch of Cmm.rec_flag * (int * instruction) list * instruction
| Iexit of int
| Itrywith of instruction * instruction
| Iraise of Cmm.raise_kind
Misc.fatal_error ("bad GC root " ^ Reg.name r)
| _ -> ())
live;
- frame_descriptors :=
- { fd_lbl = lbl;
- fd_frame_size = frame_size();
- fd_live_offset = !live_offset;
- fd_raise = raise_;
- fd_debuginfo = dbg } :: !frame_descriptors;
+ record_frame_descr ~label:lbl ~frame_size:(frame_size())
+ ~live_offset:!live_offset ~raise_frame:raise_ dbg;
`{emit_label lbl}:\n`
(* Record floating-point literals (for PPC32) *)
let rec select_addr = function
Cconst_symbol s ->
- (Asymbol s, 0)
- | Cop((Caddi | Caddv | Cadda), [arg; Cconst_int m]) ->
- let (a, n) = select_addr arg in (a, n + m)
- | Cop((Caddi | Caddv | Cadda), [Cconst_int m; arg]) ->
- let (a, n) = select_addr arg in (a, n + m)
- | Cop((Caddi | Caddv | Cadda), [arg1; arg2]) ->
+ (Asymbol s, 0, Debuginfo.none)
+ | Cop((Caddi | Caddv | Cadda), [arg; Cconst_int m], dbg) ->
+ let (a, n, _) = select_addr arg in (a, n + m, dbg)
+ | Cop((Caddi | Caddv | Cadda), [Cconst_int m; arg], dbg) ->
+ let (a, n, _) = select_addr arg in (a, n + m, dbg)
+ | Cop((Caddi | Caddv | Cadda), [arg1; arg2], dbg) ->
begin match (select_addr arg1, select_addr arg2) with
- ((Alinear e1, n1), (Alinear e2, n2)) ->
- (Aadd(e1, e2), n1 + n2)
+ ((Alinear e1, n1, _), (Alinear e2, n2, _)) ->
+ (Aadd(e1, e2), n1 + n2, dbg)
| _ ->
- (Aadd(arg1, arg2), 0)
+ (Aadd(arg1, arg2), 0, dbg)
end
| exp ->
- (Alinear exp, 0)
+ (Alinear exp, 0, Debuginfo.none)
(* Instruction selection *)
method select_addressing _chunk exp =
match select_addr exp with
- (Asymbol s, d) ->
+ (Asymbol s, d, _dbg) ->
(Ibased(s, d), Ctuple [])
- | (Alinear e, d) ->
+ | (Alinear e, d, _dbg) ->
(Iindexed d, e)
- | (Aadd(e1, e2), d) ->
+ | (Aadd(e1, e2), d, dbg) ->
if d = 0
then (Iindexed2, Ctuple[e1; e2])
- else (Iindexed d, Cop(Cadda, [e1; e2]))
+ else (Iindexed d, Cop(Cadda, [e1; e2], dbg))
-method! select_operation op args =
+method! select_operation op args dbg =
match (op, args) with
(* PowerPC does not support immediate operands for multiply high *)
(Cmulhi, _) -> (Iintop Imulh, args)
| (Cor, _) -> self#select_logical Ior args
| (Cxor, _) -> self#select_logical Ixor args
(* Recognize mult-add and mult-sub instructions *)
- | (Caddf, [Cop(Cmulf, [arg1; arg2]); arg3]) ->
+ | (Caddf, [Cop(Cmulf, [arg1; arg2], _); arg3]) ->
(Ispecific Imultaddf, [arg1; arg2; arg3])
- | (Caddf, [arg3; Cop(Cmulf, [arg1; arg2])]) ->
+ | (Caddf, [arg3; Cop(Cmulf, [arg1; arg2], _)]) ->
(Ispecific Imultaddf, [arg1; arg2; arg3])
- | (Csubf, [Cop(Cmulf, [arg1; arg2]); arg3]) ->
+ | (Csubf, [Cop(Cmulf, [arg1; arg2], _); arg3]) ->
(Ispecific Imultsubf, [arg1; arg2; arg3])
| _ ->
- super#select_operation op args
+ super#select_operation op args dbg
method select_logical op = function
[arg; Cconst_int n] when n >= 0 && n <= 0xFFFF ->
open Format
open Cmm
+let rec_flag ppf = function
+ | Nonrecursive -> ()
+ | Recursive -> fprintf ppf " rec"
+
let machtype_component ppf = function
| Val -> fprintf ppf "val"
| Addr -> fprintf ppf "addr"
| 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, _) ->
+let operation d = function
+ | Capply _ty -> "app" ^ Debuginfo.to_string d
+ | Cextcall(lbl, _ty, _alloc, _) ->
Printf.sprintf "extcall \"%s\"%s" lbl (Debuginfo.to_string d)
- | Cload c -> Printf.sprintf "load %s" (chunk c)
- | Calloc d -> "alloc" ^ Debuginfo.to_string d
+ | Cload (c, Asttypes.Immutable) -> Printf.sprintf "load %s" (chunk c)
+ | Cload (c, Asttypes.Mutable) -> Printf.sprintf "load_mut %s" (chunk c)
+ | Calloc -> "alloc" ^ Debuginfo.to_string d
| Cstore (c, init) ->
let init =
match init with
- | Lambda.Initialization -> "(init)"
+ | Lambda.Heap_initialization -> "(heap-init)"
+ | Lambda.Root_initialization -> "(root-init)"
| Lambda.Assignment -> ""
in
Printf.sprintf "store %s%s" (chunk c) init
| Cfloatofint -> "floatofint"
| Cintoffloat -> "intoffloat"
| Ccmpf c -> Printf.sprintf "%sf" (comparison c)
- | Craise (k, d) -> Format.asprintf "%a%s" raise_kind k (Debuginfo.to_string d)
- | Ccheckbound d -> "checkbound" ^ Debuginfo.to_string d
+ | Craise k -> Format.asprintf "%a%s" raise_kind k (Debuginfo.to_string d)
+ | Ccheckbound -> "checkbound" ^ Debuginfo.to_string d
let rec expr ppf = function
| Cconst_int n -> fprintf ppf "%i" n
expr ppf e)
el in
fprintf ppf "@[<1>[%a]@]" tuple el
- | Cop(op, el) ->
- fprintf ppf "@[<2>(%s" (operation op);
+ | Cop(op, el, dbg) ->
+ fprintf ppf "@[<2>(%s" (operation dbg op);
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
+ | Capply mty -> fprintf ppf "@ %a" machtype mty
+ | Cextcall(_, mty, _, _) -> fprintf ppf "@ %a" machtype mty
| _ -> ()
end;
fprintf ppf ")@]"
fprintf ppf "@[<2>(seq@ %a@ %a)@]" sequence e1 sequence e2
| Cifthenelse(e1, e2, e3) ->
fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" expr e1 expr e2 expr e3
- | Cswitch(e1, index, cases) ->
+ | Cswitch(e1, index, cases, _dbg) ->
let print_case i ppf =
for j = 0 to Array.length index - 1 do
if index.(j) = i then fprintf ppf "case %i:" j
fprintf ppf "@[<v 0>@[<2>(switch@ %a@ @]%t)@]" expr e1 print_cases
| Cloop e ->
fprintf ppf "@[<2>(loop@ %a)@]" sequence e
- | Ccatch(i, ids, e1, e2) ->
+ | Ccatch(flag, handlers, e1) ->
+ let print_handler ppf (i, ids, e2) =
+ fprintf ppf "(%d%a)@ %a"
+ i
+ (fun ppf ids ->
+ List.iter
+ (fun id -> fprintf ppf " %a" Ident.print id)
+ ids) ids
+ sequence e2
+ in
+ let print_handlers ppf l =
+ List.iter (print_handler ppf) l
+ in
fprintf ppf
- "@[<2>(catch@ %a@;<1 -2>with(%d%a)@ %a)@]"
- sequence e1 i
- (fun ppf ids ->
- List.iter
- (fun id -> fprintf ppf " %a" Ident.print id)
- ids) ids
- sequence e2
+ "@[<2>(catch%a@ %a@;<1 -2>with%a)@]"
+ rec_flag flag
+ sequence e1
+ print_handlers handlers
| Cexit (i, el) ->
- fprintf ppf "@[<2>(exit %d" i ;
+ fprintf ppf "@[<2>(exit %d" i;
List.iter (fun e -> fprintf ppf "@ %a" expr e) el;
fprintf ppf ")@]"
| Ctrywith(e1, id, e2) ->
open Format
+val rec_flag : formatter -> Cmm.rec_flag -> unit
val machtype_component : formatter -> Cmm.machtype_component -> unit
val machtype : formatter -> Cmm.machtype_component array -> unit
val comparison : Cmm.comparison -> string
val chunk : Cmm.memory_chunk -> string
-val operation : Cmm.operation -> string
+val operation : Debuginfo.t -> Cmm.operation -> string
val expression : formatter -> Cmm.expression -> unit
val fundecl : formatter -> Cmm.fundecl -> unit
val data : formatter -> Cmm.data_item list -> unit
fprintf ppf "@,endswitch"
| Iloop(body) ->
fprintf ppf "@[<v 2>loop@,%a@;<0 -2>endloop@]" instr body
- | Icatch(i, body, handler) ->
- fprintf
- ppf "@[<v 2>catch@,%a@;<0 -2>with(%d)@,%a@;<0 -2>endcatch@]"
- instr body i instr handler
+ | Icatch(flag, handlers, body) ->
+ fprintf ppf "@[<v 2>catch%a@,%a@;<0 -2>with"
+ Printcmm.rec_flag flag instr body;
+ let h (nfail, handler) =
+ fprintf ppf "(%d)@,%a@;" nfail instr handler in
+ let rec aux = function
+ | [] -> ()
+ | [v] -> h v
+ | v :: t ->
+ h v;
+ fprintf ppf "@ and";
+ aux t
+ in
+ aux handlers
| Iexit i ->
fprintf ppf "exit(%d)" i
| Itrywith(body, handler) ->
(self#reload i.next))
| Iloop body ->
instr_cons (Iloop(self#reload body)) [||] [||] (self#reload i.next)
- | Icatch(nfail, body, handler) ->
+ | Icatch(rec_flag, handlers, body) ->
+ let new_handlers = List.map
+ (fun (nfail, handler) -> nfail, self#reload handler)
+ handlers in
instr_cons
- (Icatch(nfail, self#reload body, self#reload handler)) [||] [||]
+ (Icatch(rec_flag, new_handlers, self#reload body)) [||] [||]
(self#reload i.next)
| Iexit i ->
instr_cons (Iexit i) [||] [||] dummy_instr
(* Output function call *)
let emit_call s =
- if !pic_code then
- `brasl %r14, {emit_symbol s}@PLT`
- else
- `brasl %r14, {emit_symbol s}`
+ if !pic_code then
+ ` brasl %r14, {emit_symbol s}@PLT\n`
+ else
+ ` brasl %r14, {emit_symbol s}\n`
(* Output a label *)
(* Special registers *)
-let reg_f15 = phys_reg 115
+let check_phys_reg reg_idx name =
+ let reg = phys_reg reg_idx in
+ assert (register_name reg_idx = name);
+ reg
+
+let reg_f15 = check_phys_reg 115 "%f15"
+let reg_r7 = check_phys_reg 5 "%r7"
(* Output a stack reference *)
| _ -> fatal_error "Emit.emit_stack"
+(* Output a load of the address of a global symbol *)
+
+let emit_load_symbol_addr reg s =
+ if !pic_code then
+ ` lgrl {emit_reg reg}, {emit_symbol s}@GOTENT\n`
+ else
+ ` larl {emit_reg reg}, {emit_symbol s}\n`
+
(* Output a load or store operation *)
let emit_load_store instr addressing_mode addr n arg =
(* Record live pointers at call points *)
-let record_frame ?label live raise_ dbg =
+let record_frame_label ?label live raise_ dbg =
let lbl =
match label with
| None -> new_label()
Misc.fatal_error ("bad GC root " ^ Reg.name r)
| _ -> ())
live;
- frame_descriptors :=
- { fd_lbl = lbl;
- fd_frame_size = frame_size();
- fd_live_offset = !live_offset;
- fd_raise = raise_;
- fd_debuginfo = dbg } :: !frame_descriptors;
+ record_frame_descr ~label:lbl ~frame_size:(frame_size())
+ ~live_offset:!live_offset ~raise_frame:raise_ dbg;
lbl
+let record_frame ?label live raise_ dbg =
+ let lbl = record_frame_label ?label live raise_ dbg in
+ `{emit_label lbl}:`
+
(* Record calls to caml_call_gc, emitted out of line. *)
type gc_call =
let call_gc_sites = ref ([] : gc_call list)
let emit_call_gc gc =
- `{emit_label gc.gc_lbl}: {emit_call "caml_call_gc"}\n`;
+ `{emit_label gc.gc_lbl}:`; emit_call "caml_call_gc";
`{emit_label gc.gc_frame_lbl}: brcl 15, {emit_label gc.gc_return_lbl}\n`
(* Record calls to caml_ml_array_bound_error, emitted out of line. *)
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 false 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
end
let emit_call_bound_error bd =
- `{emit_label bd.bd_lbl}: {emit_call "caml_ml_array_bound_error"}\n`;
+ `{emit_label bd.bd_lbl}:`; emit_call "caml_ml_array_bound_error";
`{emit_label bd.bd_frame}:\n`
let emit_call_bound_errors () =
List.iter emit_call_bound_error !bound_error_sites;
- if !bound_error_call > 0 then
- `{emit_label !bound_error_call}: {emit_call "caml_ml_array_bound_error"}\n`
+ if !bound_error_call > 0 then begin
+ `{emit_label !bound_error_call}:`; emit_call "caml_ml_array_bound_error";
+ end
(* Record floating-point and large integer literals *)
` larl %r1, {emit_label lbl}\n`;
` ld {emit_reg i.res.(0)}, 0(%r1)\n`
| Lop(Iconst_symbol s) ->
- if !pic_code then
- ` lgrl {emit_reg i.res.(0)}, {emit_symbol s}@GOTENT\n`
- else
- ` larl {emit_reg i.res.(0)}, {emit_symbol s}\n`;
+ emit_load_symbol_addr i.res.(0) s
| Lop(Icall_ind { label_after; }) ->
` basr %r14, {emit_reg i.arg.(0)}\n`;
- let lbl = record_frame i.live false i.dbg ~label:label_after in
- `{emit_label lbl}:\n`
+ `{record_frame i.live false i.dbg ~label:label_after}\n`
| Lop(Icall_imm { func; label_after; }) ->
- if !pic_code then
- ` brasl %r14, {emit_symbol func}@PLT\n`
- else
- ` brasl %r14, {emit_symbol func}\n`;
- let lbl = record_frame i.live false i.dbg ~label:label_after in
- `{emit_label lbl}:\n`;
+ emit_call func;
+ `{record_frame i.live false i.dbg ~label:label_after}\n`
| Lop(Itailcall_ind { label_after = _; }) ->
let n = frame_size() in
if !contains_calls then
end
| Lop(Iextcall { func; alloc; label_after; }) ->
- if alloc then begin
- if !pic_code then begin
- ` lgrl %r7, {emit_symbol func}@GOTENT\n`;
- ` brasl %r14, {emit_symbol "caml_c_call"}@PLT\n`
- end else begin
- ` larl %r7, {emit_symbol func}\n`;
- ` brasl %r14, {emit_symbol "caml_c_call"}\n`
- end;
- 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 func}@PLT\n`
- else
- ` brasl %r14, {emit_symbol func}\n`
- end
+ if not alloc then emit_call func
+ else begin
+ emit_load_symbol_addr reg_r7 func;
+ emit_call "caml_c_call";
+ `{record_frame i.live false i.dbg ~label:label_after}\n`
+ end
| Lop(Istackoffset n) ->
emit_stack_adjust n;
let lbl_redo = new_label() in
let lbl_call_gc = new_label() in
let lbl_frame =
- record_frame i.live false i.dbg ?label:label_after_call_gc
+ record_frame_label i.live false i.dbg ?label:label_after_call_gc
in
call_gc_sites :=
{ gc_lbl = lbl_call_gc;
| Lraise k ->
begin match k with
| Cmm.Raise_withtrace ->
- ` brasl %r14, {emit_symbol "caml_raise_exn"}\n`;
- let lbl = record_frame Reg.Set.empty true i.dbg in
- `{emit_label lbl}:\n`
+ emit_call "caml_raise_exn";
+ `{record_frame Reg.Set.empty true i.dbg}\n`
| Cmm.Raise_notrace ->
` lg %r1, 0(%r13)\n`;
` lgr %r15, %r13\n`;
| Aadd of expression * expression
let rec select_addr = function
- | Cop((Caddi | Cadda | Caddv), [arg; Cconst_int m]) ->
+ | Cop((Caddi | Cadda | Caddv), [arg; Cconst_int m], _) ->
let (a, n) = select_addr arg in (a, n + m)
- | Cop((Caddi | Cadda | Caddv), [Cconst_int m; arg]) ->
+ | Cop((Caddi | Cadda | Caddv), [Cconst_int m; arg], _) ->
let (a, n) = select_addr arg in (a, n + m)
- | Cop((Caddi | Cadda | Caddv), [arg1; arg2]) ->
+ | Cop((Caddi | Cadda | Caddv), [arg1; arg2], _) ->
begin match (select_addr arg1, select_addr arg2) with
((Alinear e1, n1), (Alinear e2, n2)) ->
(Aadd(e1, e2), n1 + n2)
end else
(Iindexed 0, exp)
-method! select_operation op args =
+method! select_operation op args dbg =
match (op, args) with
(* Z does not support immediate operands for multiply high *)
(Cmulhi, _) -> (Iintop Imulh, 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]) ->
+ | (Caddf, [Cop(Cmulf, [arg1; arg2], _); arg3]) ->
(Ispecific Imultaddf, [arg1; arg2; arg3])
- | (Caddf, [arg3; Cop(Cmulf, [arg1; arg2])]) ->
+ | (Caddf, [arg3; Cop(Cmulf, [arg1; arg2], _)]) ->
(Ispecific Imultaddf, [arg1; arg2; arg3])
- | (Csubf, [Cop(Cmulf, [arg1; arg2]); arg3]) ->
+ | (Csubf, [Cop(Cmulf, [arg1; arg2], _); arg3]) ->
(Ispecific Imultsubf, [arg1; arg2; arg3])
| _ ->
- super#select_operation op args
+ super#select_operation op args dbg
method select_logical op lo hi = function
[arg; Cconst_int n] when n >= lo && n <= hi ->
open Reg
open Mach
-type environment = (Ident.t, Reg.t array) Tbl.t
+type environment =
+ { vars : (Ident.t, Reg.t array) Tbl.t;
+ static_exceptions : (int, Reg.t array list) Tbl.t;
+ (** Which registers must be populated when jumping to the given
+ handler. *)
+ }
+
+let env_add id v env =
+ { env with vars = Tbl.add id v env.vars }
+
+let env_add_static_exception id v env =
+ { env with static_exceptions = Tbl.add id v env.static_exceptions }
+
+let env_find id env =
+ Tbl.find id env.vars
+
+let env_find_static_exception id env =
+ Tbl.find id env.static_exceptions
+
+let env_empty = {
+ vars = Tbl.empty;
+ static_exceptions = Tbl.empty;
+}
(* Infer the type of the result of an operation *)
let oper_result_type = function
- Capply(ty, _) -> ty
- | Cextcall(_s, ty, _alloc, _, _) -> ty
- | Cload c ->
+ Capply ty -> 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
+ | Calloc -> typ_val
| Cstore (_c, _) -> typ_void
| Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi |
Cand | Cor | Cxor | Clsl | Clsr | Casr |
| Cfloatofint -> typ_float
| Cintoffloat -> typ_int
| Craise _ -> typ_void
- | Ccheckbound _ -> typ_void
+ | Ccheckbound -> typ_void
-(* Infer the size in bytes of the result of a simple expression *)
+(* Infer the size in bytes of the result of an expression whose evaluation
+ may be deferred (cf. [emit_parts]). *)
-let size_expr env exp =
+let size_expr (env:environment) exp =
let rec size localenv = function
Cconst_int _ | Cconst_natint _ -> Arch.size_int
| Cconst_symbol _ | Cconst_pointer _ | Cconst_natpointer _ ->
Tbl.find id localenv
with Not_found ->
try
- let regs = Tbl.find id env in
+ let regs = env_find id env in
size_machtype (Array.map (fun r -> r.typ) regs)
with Not_found ->
fatal_error("Selection.size_expr: unbound var " ^
end
| Ctuple el ->
List.fold_right (fun e sz -> size localenv e + sz) el 0
- | Cop(op, _) ->
+ | Cop(op, _, _) ->
size_machtype(oper_result_type op)
| Clet(id, arg, body) ->
size (Tbl.add id (size localenv arg) localenv) body
done;
Some res
-(* Extract debug info contained in a C-- operation *)
-let debuginfo_op = function
- | Capply(_, dbg) -> dbg
- | Cextcall(_, _, _, dbg, _) -> dbg
- | Craise (_, dbg) -> dbg
- | Ccheckbound dbg -> dbg
- | Calloc dbg -> dbg
- | _ -> Debuginfo.none
-
-(* Registers for catch constructs *)
-let catch_regs = ref []
-
(* Name of function being compiled *)
let current_function_name = ref ""
+module Effect = struct
+ type t =
+ | None
+ | Raise
+ | Arbitrary
+
+ let join t1 t2 =
+ match t1, t2 with
+ | None, t2 -> t2
+ | t1, None -> t1
+ | Raise, Raise -> Raise
+ | Arbitrary, _ | _, Arbitrary -> Arbitrary
+
+ let pure = function
+ | None -> true
+ | Raise | Arbitrary -> false
+end
+
+module Coeffect = struct
+ type t =
+ | None
+ | Read_mutable
+ | Arbitrary
+
+ let join t1 t2 =
+ match t1, t2 with
+ | None, t2 -> t2
+ | t1, None -> t1
+ | Read_mutable, Read_mutable -> Read_mutable
+ | Arbitrary, _ | _, Arbitrary -> Arbitrary
+
+ let copure = function
+ | None -> true
+ | Read_mutable | Arbitrary -> false
+end
+
+module Effect_and_coeffect : sig
+ type t
+
+ val none : t
+ val arbitrary : t
+
+ val effect : t -> Effect.t
+ val coeffect : t -> Coeffect.t
+
+ val pure_and_copure : t -> bool
+
+ val effect_only : Effect.t -> t
+ val coeffect_only : Coeffect.t -> t
+
+ val join : t -> t -> t
+ val join_list_map : 'a list -> ('a -> t) -> t
+end = struct
+ type t = Effect.t * Coeffect.t
+
+ let none = Effect.None, Coeffect.None
+ let arbitrary = Effect.Arbitrary, Coeffect.Arbitrary
+
+ let effect (e, _ce) = e
+ let coeffect (_e, ce) = ce
+
+ let pure_and_copure (e, ce) = Effect.pure e && Coeffect.copure ce
+
+ let effect_only e = e, Coeffect.None
+ let coeffect_only ce = Effect.None, ce
+
+ let join (e1, ce1) (e2, ce2) =
+ Effect.join e1 e2, Coeffect.join ce1 ce2
+
+ let join_list_map xs f =
+ match xs with
+ | [] -> none
+ | x::xs -> List.fold_left (fun acc x -> join acc (f x)) (f x) xs
+end
+
(* The default instruction selection class *)
class virtual selector_generic = object (self)
-(* Says if an expression is "simple". A "simple" expression has no
- side-effects and its execution can be delayed until its value
- is really needed. In the case of e.g. an [alloc] instruction,
- the non-simple arguments are computed in right-to-left order
- first, then the block is allocated, then the simple arguments are
- evaluated and stored. *)
-
+(* A syntactic criterion used in addition to judgements about (co)effects as
+ to whether the evaluation of a given expression may be deferred by
+ [emit_parts]. This criterion is a property of the instruction selection
+ algorithm in this file rather than a property of the Cmm language.
+*)
method is_simple_expr = function
Cconst_int _ -> true
| Cconst_natint _ -> 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
| Csequence(e1, e2) -> self#is_simple_expr e1 && self#is_simple_expr e2
- | Cop(op, args) ->
+ | 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
+ | Cload _ | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi | Cand | Cor
+ | Cxor | Clsl | Clsr | Casr | Ccmpi _ | Caddv | Cadda | Ccmpa _ | Cnegf
+ | Cabsf | Caddf | Csubf | Cmulf | Cdivf | Cfloatofint | Cintoffloat
+ | Ccmpf _ | Ccheckbound -> List.for_all self#is_simple_expr args
end
- | _ -> false
+ | Cassign _ | Cifthenelse _ | Cswitch _ | Cloop _ | Ccatch _ | Cexit _
+ | Ctrywith _ -> false
+
+(* Analyses the effects and coeffects of an expression. This is used across
+ a whole list of expressions with a view to determining which expressions
+ may have their evaluation deferred. The result of this function, modulo
+ target-specific judgements if the [effects_of] method is overridden, is a
+ property of the Cmm language rather than anything particular about the
+ instruction selection algorithm in this file.
+
+ In the case of e.g. an OCaml function call, the arguments whose evaluation
+ cannot be deferred (cf. [emit_parts], below) are computed in right-to-left
+ order first with their results going into temporaries, then the block is
+ allocated, then the remaining arguments are evaluated before being
+ combined with the temporaries. *)
+method effects_of exp =
+ let module EC = Effect_and_coeffect in
+ match exp with
+ | Cconst_int _ | Cconst_natint _ | Cconst_float _ | Cconst_symbol _
+ | Cconst_pointer _ | Cconst_natpointer _ | Cblockheader _
+ | Cvar _ -> EC.none
+ | Ctuple el -> EC.join_list_map el self#effects_of
+ | Clet (_id, arg, body) ->
+ EC.join (self#effects_of arg) (self#effects_of body)
+ | Csequence (e1, e2) ->
+ EC.join (self#effects_of e1) (self#effects_of e2)
+ | Cifthenelse (cond, ifso, ifnot) ->
+ EC.join (self#effects_of cond)
+ (EC.join (self#effects_of ifso) (self#effects_of ifnot))
+ | Cop (op, args, _) ->
+ let from_op =
+ match op with
+ | Capply _ | Cextcall _ -> EC.arbitrary
+ | Calloc -> EC.none
+ | Cstore _ -> EC.effect_only Effect.Arbitrary
+ | Craise _ | Ccheckbound -> EC.effect_only Effect.Raise
+ | Cload (_, Asttypes.Immutable) -> EC.none
+ | Cload (_, Asttypes.Mutable) -> EC.coeffect_only Coeffect.Read_mutable
+ | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi | Cand | Cor | Cxor
+ | Clsl | Clsr | Casr | Ccmpi _ | Caddv | Cadda | Ccmpa _ | Cnegf | Cabsf
+ | Caddf | Csubf | Cmulf | Cdivf | Cfloatofint | Cintoffloat | Ccmpf _ ->
+ EC.none
+ in
+ EC.join from_op (EC.join_list_map args self#effects_of)
+ | Cassign _ | Cswitch _ | Cloop _ | Ccatch _ | Cexit _ | Ctrywith _ ->
+ EC.arbitrary
(* Says whether an integer constant is a suitable immediate argument *)
Icheckbound { spacetime_index = 0; label_after_error = None; }
method select_checkbound_extra_args () = []
-method select_operation op args =
+method select_operation op args _dbg =
match (op, args) with
| (Capply _, Cconst_symbol func :: rem) ->
let label_after = Cmm.new_label () in
| (Capply _, _) ->
let label_after = Cmm.new_label () in
(Icall_ind { label_after; }, args)
- | (Cextcall(func, _ty, alloc, _dbg, label_after), _) ->
+ | (Cextcall(func, _ty, alloc, 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]) ->
+ | (Cload (chunk, _mut), [arg]) ->
let (addr, eloc) = self#select_addressing chunk arg in
(Iload(chunk, addr), [eloc])
| (Cstore (chunk, init), [arg1; arg2]) ->
let (addr, eloc) = self#select_addressing chunk arg1 in
let is_assign =
match init with
- | Lambda.Initialization -> false
+ | Lambda.Root_initialization -> false
+ | Lambda.Heap_initialization -> false
| Lambda.Assignment -> true
in
if chunk = Word_int || chunk = Word_val then begin
(Istore(chunk, addr, is_assign), [arg2; eloc])
(* Inversion addr/datum in Istore *)
end
- | (Calloc _dbg, _) -> (self#select_allocation 0), args
+ | (Calloc, _) -> (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
| (Cdivf, _) -> (Idivf, args)
| (Cfloatofint, _) -> (Ifloatofint, args)
| (Cintoffloat, _) -> (Iintoffloat, args)
- | (Ccheckbound _, _) ->
+ | (Ccheckbound, _) ->
let extra_args = self#select_checkbound_extra_args () in
let op = self#select_checkbound () in
self#select_arith op (args @ extra_args)
(* Instruction selection for conditionals *)
method select_condition = function
- Cop(Ccmpi cmp, [arg1; Cconst_int n]) when self#is_immediate n ->
+ Cop(Ccmpi cmp, [arg1; Cconst_int n], _) when self#is_immediate n ->
(Iinttest_imm(Isigned cmp, n), arg1)
- | Cop(Ccmpi cmp, [Cconst_int n; arg2]) when self#is_immediate n ->
+ | Cop(Ccmpi cmp, [Cconst_int n; arg2], _) when self#is_immediate n ->
(Iinttest_imm(Isigned(swap_comparison cmp), n), arg2)
- | Cop(Ccmpi cmp, [arg1; Cconst_pointer n]) when self#is_immediate n ->
+ | Cop(Ccmpi cmp, [arg1; Cconst_pointer n], _) when self#is_immediate n ->
(Iinttest_imm(Isigned cmp, n), arg1)
- | Cop(Ccmpi cmp, [Cconst_pointer n; arg2]) when self#is_immediate n ->
+ | Cop(Ccmpi cmp, [Cconst_pointer n; arg2], _) when self#is_immediate n ->
(Iinttest_imm(Isigned(swap_comparison cmp), n), arg2)
- | Cop(Ccmpi cmp, args) ->
+ | Cop(Ccmpi cmp, args, _) ->
(Iinttest(Isigned cmp), Ctuple args)
- | Cop(Ccmpa cmp, [arg1; Cconst_pointer n]) when self#is_immediate n ->
+ | Cop(Ccmpa cmp, [arg1; Cconst_pointer n], _) when self#is_immediate n ->
(Iinttest_imm(Iunsigned cmp, n), arg1)
- | Cop(Ccmpa cmp, [arg1; Cconst_int n]) when self#is_immediate n ->
+ | Cop(Ccmpa cmp, [arg1; Cconst_int n], _) when self#is_immediate n ->
(Iinttest_imm(Iunsigned cmp, n), arg1)
- | Cop(Ccmpa cmp, [Cconst_pointer n; arg2]) when self#is_immediate n ->
+ | Cop(Ccmpa cmp, [Cconst_pointer n; arg2], _) when self#is_immediate n ->
(Iinttest_imm(Iunsigned(swap_comparison cmp), n), arg2)
- | Cop(Ccmpa cmp, [Cconst_int n; arg2]) when self#is_immediate n ->
+ | Cop(Ccmpa cmp, [Cconst_int n; arg2], _) when self#is_immediate n ->
(Iinttest_imm(Iunsigned(swap_comparison cmp), n), arg2)
- | Cop(Ccmpa cmp, args) ->
+ | Cop(Ccmpa cmp, args, _) ->
(Iinttest(Iunsigned cmp), Ctuple args)
- | Cop(Ccmpf cmp, args) ->
+ | Cop(Ccmpf cmp, args, _) ->
(Ifloattest(cmp, false), Ctuple args)
- | Cop(Cand, [arg; Cconst_int 1]) ->
+ | Cop(Cand, [arg; Cconst_int 1], _) ->
(Ioddtest, arg)
| arg ->
(Itruetest, arg)
(* Add the instructions for the given expression
at the end of the self sequence *)
-method emit_expr env exp =
+method emit_expr (env:environment) exp =
match exp with
Cconst_int n ->
let r = self#regs_for typ_int in
self#emit_blockheader env n dbg
| Cvar v ->
begin try
- Some(Tbl.find v env)
+ Some(env_find v env)
with Not_found ->
fatal_error("Selection.emit_expr: unbound var " ^ Ident.unique_name v)
end
| Cassign(v, e1) ->
let rv =
try
- Tbl.find v env
+ env_find v env
with Not_found ->
fatal_error ("Selection.emit_expr: unbound var " ^ Ident.name v) in
begin match self#emit_expr env e1 with
| Some(simple_list, ext_env) ->
Some(self#emit_tuple ext_env simple_list)
end
- | Cop(Craise (k, dbg), [arg]) ->
+ | Cop(Craise k, [arg], dbg) ->
begin match self#emit_expr env arg with
None -> None
| Some r1 ->
self#insert_debug (Iraise k) dbg rd [||];
None
end
- | Cop(Ccmpf _, _) ->
+ | Cop(Ccmpf _, _, _) ->
self#emit_expr env (Cifthenelse(exp, Cconst_int 1, Cconst_int 0))
- | Cop(op, args) ->
+ | Cop(op, args, dbg) ->
begin match self#emit_parts_list env args with
None -> None
| Some(simple_args, env) ->
let ty = oper_result_type op in
- let (new_op, new_args) = self#select_operation op simple_args in
- let dbg = debuginfo_op op in
+ let (new_op, new_args) = self#select_operation op simple_args dbg in
match new_op with
Icall_ind _ ->
let r1 = self#emit_tuple env new_args in
rarg [||];
r
end
- | Cswitch(esel, index, ecases) ->
+ | Cswitch(esel, index, ecases, _dbg) ->
begin match self#emit_expr env esel with
None -> None
| Some rsel ->
let (_rarg, sbody) = self#emit_sequence env ebody in
self#insert (Iloop(sbody#extract)) [||] [||];
Some [||]
- | Ccatch(nfail, ids, e1, e2) ->
- let rs =
- List.map
- (fun id ->
- let r = self#regs_for typ_val in name_regs id r; r)
- ids in
- catch_regs := (nfail, Array.concat rs) :: !catch_regs ;
- let (r1, s1) = self#emit_sequence env e1 in
- catch_regs := List.tl !catch_regs ;
- let new_env =
- List.fold_left
- (fun env (id,r) -> Tbl.add id r env)
- env (List.combine ids rs) in
- let (r2, s2) = self#emit_sequence new_env e2 in
- let r = join r1 s1 r2 s2 in
- self#insert (Icatch(nfail, s1#extract, s2#extract)) [||] [||];
+ | Ccatch(_, [], e1) ->
+ self#emit_expr env e1
+ | Ccatch(rec_flag, handlers, body) ->
+ let handlers =
+ List.map (fun (nfail, ids, e2) ->
+ let rs =
+ List.map
+ (* CR-someday mshinwell: consider how we can do better than
+ [typ_val] when appropriate. *)
+ (fun id -> let r = self#regs_for typ_val in name_regs id r; r)
+ ids in
+ (nfail, ids, rs, e2))
+ handlers
+ in
+ let env =
+ (* Since the handlers may be recursive, and called from the body,
+ the same environment is used for translating both the handlers and
+ the body. *)
+ List.fold_left (fun env (nfail, _ids, rs, _e2) ->
+ env_add_static_exception nfail rs env)
+ env handlers
+ in
+ let (r_body, s_body) = self#emit_sequence env body in
+ let translate_one_handler (nfail, ids, rs, e2) =
+ assert(List.length ids = List.length rs);
+ let new_env =
+ List.fold_left (fun env (id, r) -> env_add id r env)
+ env (List.combine ids rs)
+ in
+ let (r, s) = self#emit_sequence new_env e2 in
+ (nfail, (r, s))
+ in
+ let l = List.map translate_one_handler handlers in
+ let a = Array.of_list ((r_body, s_body) :: List.map snd l) in
+ let r = join_array a in
+ let aux (nfail, (_r, s)) = (nfail, s#extract) in
+ self#insert (Icatch (rec_flag, List.map aux l, s_body#extract)) [||] [||];
r
| Cexit (nfail,args) ->
begin match self#emit_parts_list env args with
None -> None
| Some (simple_list, ext_env) ->
let src = self#emit_tuple ext_env simple_list in
- let dest =
- try List.assoc nfail !catch_regs
+ let dest_args =
+ try env_find_static_exception nfail env
with Not_found ->
- Misc.fatal_error
- ("Selectgen.emit_expr, on exit("^string_of_int nfail^")") in
- self#insert_moves src dest ;
+ fatal_error ("Selection.emit_expr: unboun label "^
+ string_of_int nfail)
+ in
+ (* Intermediate registers to handle cases where some
+ registers from src are present in dest *)
+ let tmp_regs = Reg.createv_like src in
+ (* Ccatch registers are created with type Val. They must not
+ contain out of heap pointers *)
+ Array.iter (fun reg -> assert(reg.typ <> Addr)) src;
+ self#insert_moves src tmp_regs ;
+ self#insert_moves tmp_regs (Array.concat dest_args) ;
self#insert (Iexit nfail) [||] [||];
None
end
| Ctrywith(e1, v, e2) ->
let (r1, s1) = self#emit_sequence env e1 in
let rv = self#regs_for typ_val in
- let (r2, s2) = self#emit_sequence (Tbl.add v rv env) e2 in
+ let (r2, s2) = self#emit_sequence (env_add v rv env) e2 in
let r = join r1 s1 r2 s2 in
self#insert
(Itrywith(s1#extract,
[||] [||];
r
-method private emit_sequence env exp =
+method private emit_sequence (env:environment) exp =
let s = {< instr_seq = dummy_instr >} in
let r = s#emit_expr env exp in
(r, s)
-method private bind_let env v r1 =
+method private bind_let (env:environment) v r1 =
if all_regs_anonymous r1 then begin
name_regs v r1;
- Tbl.add v r1 env
+ env_add v r1 env
end else begin
let rv = Reg.createv_like r1 in
name_regs v rv;
self#insert_moves r1 rv;
- Tbl.add v rv env
+ env_add v rv env
end
-method private emit_parts env exp =
- if self#is_simple_expr exp then
+(* The following two functions, [emit_parts] and [emit_parts_list], force
+ right-to-left evaluation order as required by the Flambda [Un_anf] pass
+ (and to be consistent with the bytecode compiler). *)
+
+method private emit_parts (env:environment) ~effects_after exp =
+ let module EC = Effect_and_coeffect in
+ let may_defer_evaluation =
+ let ec = self#effects_of exp in
+ match EC.effect ec with
+ | Effect.Arbitrary | Effect.Raise ->
+ (* Preserve the ordering of effectful expressions by evaluating them
+ early (in the correct order) and assigning their results to
+ temporaries. We can avoid this in just one case: if we know that
+ every [exp'] in the original expression list (cf. [emit_parts_list])
+ to be evaluated after [exp] cannot possibly affect the result of
+ [exp] or depend on the result of [exp], then [exp] may be deferred.
+ (Checking purity here is not enough: we need to check copurity too
+ to avoid e.g. moving mutable reads earlier than the raising of
+ an exception.) *)
+ EC.pure_and_copure effects_after
+ | Effect.None ->
+ match EC.coeffect ec with
+ | Coeffect.None ->
+ (* Pure expressions may be moved. *)
+ true
+ | Coeffect.Read_mutable -> begin
+ (* Read-mutable expressions may only be deferred if evaluation of
+ every [exp'] (for [exp'] as in the comment above) has no effects
+ "worse" (in the sense of the ordering in [Effect.t]) than raising
+ an exception. *)
+ match EC.effect effects_after with
+ | Effect.None | Effect.Raise -> true
+ | Effect.Arbitrary -> false
+ end
+ | Coeffect.Arbitrary -> begin
+ (* Arbitrary expressions may only be deferred if evaluation of
+ every [exp'] (for [exp'] as in the comment above) has no effects. *)
+ match EC.effect effects_after with
+ | Effect.None -> true
+ | Effect.Arbitrary | Effect.Raise -> false
+ end
+ in
+ (* Even though some expressions may look like they can be deferred from
+ the (co)effect analysis, it may be forbidden to move them. *)
+ if may_defer_evaluation && self#is_simple_expr exp then
Some (exp, env)
else begin
match self#emit_expr env exp with
let id = Ident.create "bind" in
if all_regs_anonymous r then
(* r is an anonymous, unshared register; use it directly *)
- Some (Cvar id, Tbl.add id r env)
+ Some (Cvar id, env_add id r env)
else begin
(* Introduce a fresh temp to hold the result *)
let tmp = Reg.createv_like r in
self#insert_moves r tmp;
- Some (Cvar id, Tbl.add id tmp env)
+ Some (Cvar id, env_add id tmp env)
end
end
end
-method private emit_parts_list env exp_list =
- match exp_list with
- [] -> Some ([], env)
- | exp :: rem ->
- (* This ensures right-to-left evaluation, consistent with the
- bytecode compiler *)
- match self#emit_parts_list env rem with
- None -> None
- | Some(new_rem, new_env) ->
- match self#emit_parts new_env exp with
- None -> None
- | Some(new_exp, fin_env) -> Some(new_exp :: new_rem, fin_env)
+method private emit_parts_list (env:environment) exp_list =
+ let module EC = Effect_and_coeffect in
+ let exp_list_right_to_left, _effect =
+ (* Annotate each expression with the (co)effects that happen after it
+ when the original expression list is evaluated from right to left.
+ The resulting expression list has the rightmost expression first. *)
+ List.fold_left (fun (exp_list, effects_after) exp ->
+ let exp_effect = self#effects_of exp in
+ (exp, effects_after)::exp_list, EC.join exp_effect effects_after)
+ ([], EC.none)
+ exp_list
+ in
+ List.fold_left (fun results_and_env (exp, effects_after) ->
+ match results_and_env with
+ | None -> None
+ | Some (result, env) ->
+ match self#emit_parts env exp ~effects_after with
+ | None -> None
+ | Some (exp_result, env) -> Some (exp_result :: result, env))
+ (Some ([], env))
+ exp_list_right_to_left
method private emit_tuple_not_flattened env exp_list =
let rec emit_list = function
(* Same, but in tail position *)
-method private emit_return env exp =
+method private emit_return (env:environment) exp =
match self#emit_expr env exp with
None -> ()
| Some r ->
self#insert_moves r loc;
self#insert Ireturn loc [||]
-method emit_tail env exp =
+method emit_tail (env:environment) exp =
match exp with
Clet(v, e1, e2) ->
begin match self#emit_expr env e1 with
None -> ()
| Some r1 -> self#emit_tail (self#bind_let env v r1) e2
end
- | Cop(Capply(ty, dbg) as op, args) ->
+ | Cop((Capply ty) as op, args, dbg) ->
begin match self#emit_parts_list env args with
None -> ()
| Some(simple_args, env) ->
- let (new_op, new_args) = self#select_operation op simple_args in
+ let (new_op, new_args) = self#select_operation op simple_args dbg in
match new_op with
Icall_ind { label_after; } ->
let r1 = self#emit_tuple env new_args in
self#emit_tail_sequence env eelse))
rarg [||]
end
- | Cswitch(esel, index, ecases) ->
+ | Cswitch(esel, index, ecases, _dbg) ->
begin match self#emit_expr env esel with
None -> ()
| Some rsel ->
(Iswitch(index, Array.map (self#emit_tail_sequence env) ecases))
rsel [||]
end
- | Ccatch(nfail, ids, e1, e2) ->
- let rs =
- List.map
- (fun id ->
- let r = self#regs_for typ_val in
- name_regs id r ;
- r)
- ids in
- catch_regs := (nfail, Array.concat rs) :: !catch_regs ;
- let s1 = self#emit_tail_sequence env e1 in
- catch_regs := List.tl !catch_regs ;
- let new_env =
- List.fold_left
- (fun env (id,r) -> Tbl.add id r env)
- env (List.combine ids rs) in
- let s2 = self#emit_tail_sequence new_env e2 in
- self#insert (Icatch(nfail, s1, s2)) [||] [||]
+ | Ccatch(_, [], e1) ->
+ self#emit_tail env e1
+ | Ccatch(rec_flag, handlers, e1) ->
+ let handlers =
+ List.map (fun (nfail, ids, e2) ->
+ let rs =
+ List.map
+ (fun id -> let r = self#regs_for typ_val in name_regs id r; r)
+ ids in
+ (nfail, ids, rs, e2))
+ handlers in
+ let env =
+ List.fold_left (fun env (nfail, _ids, rs, _e2) ->
+ env_add_static_exception nfail rs env)
+ env handlers in
+ let s_body = self#emit_tail_sequence env e1 in
+ let aux (nfail, ids, rs, e2) =
+ assert(List.length ids = List.length rs);
+ let new_env =
+ List.fold_left
+ (fun env (id,r) -> env_add id r env)
+ env (List.combine ids rs) in
+ nfail, self#emit_tail_sequence new_env e2
+ in
+ self#insert (Icatch(rec_flag, List.map aux handlers, s_body)) [||] [||]
| Ctrywith(e1, v, e2) ->
let (opt_r1, s1) = self#emit_sequence env e1 in
let rv = self#regs_for typ_val in
- let s2 = self#emit_tail_sequence (Tbl.add v rv env) e2 in
+ let s2 = self#emit_tail_sequence (env_add v rv env) e2 in
self#insert
(Itrywith(s1#extract,
instr_cons (Iop Imove) [|Proc.loc_exn_bucket|] rv s2))
(* Sequentialization of a function definition *)
-method initial_env () = Tbl.empty
+method initial_env () = env_empty
method emit_fundecl f =
Proc.contains_calls := false;
together is then simply prepended to the body. *)
let env =
List.fold_right2
- (fun (id, _ty) r env -> Tbl.add id r env)
+ (fun (id, _ty) r env -> env_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
+ Some (node_hole, reg), env_add node_hole reg env
end
in
self#emit_tail env f.Cmm.fun_body;
Simplif.is_tail_native_heuristic := is_tail_call
let reset () =
- catch_regs := [];
current_function_name := ""
(* Selection of pseudo-instructions, assignment of pseudo-registers,
sequentialization. *)
-type environment = (Ident.t, Reg.t array) Tbl.t
+type environment
+
+val env_add : Ident.t -> Reg.t array -> environment -> environment
+
+val env_find : Ident.t -> environment -> Reg.t array
val size_expr : environment -> Cmm.expression -> int
+module Effect : sig
+ type t =
+ | None
+ | Raise
+ | Arbitrary
+end
+
+module Coeffect : sig
+ type t =
+ | None
+ | Read_mutable
+ | Arbitrary
+end
+
+module Effect_and_coeffect : sig
+ type t
+
+ val none : t
+ val arbitrary : t
+
+ val effect : t -> Effect.t
+ val coeffect : t -> Coeffect.t
+
+ val effect_only : Effect.t -> t
+ val coeffect_only : Coeffect.t -> t
+
+ val join : t -> t -> t
+ val join_list_map : 'a list -> ('a -> t) -> t
+end
+
class virtual selector_generic : object
(* The following methods must or can be overridden by the processor
description *)
Cmm.memory_chunk -> Cmm.expression -> Arch.addressing_mode * Cmm.expression
(* Must be defined to select addressing modes *)
method is_simple_expr: Cmm.expression -> bool
+ method effects_of : Cmm.expression -> Effect_and_coeffect.t
(* Can be overridden to reflect special extcalls known to be pure *)
method select_operation :
Cmm.operation ->
- Cmm.expression list -> Mach.operation * Cmm.expression list
+ Cmm.expression list ->
+ Debuginfo.t ->
+ Mach.operation * Cmm.expression list
(* Can be overridden to deal with special arithmetic instructions *)
method select_condition : Cmm.expression -> Mach.test * Cmm.expression
(* Can be overridden to deal with special test instructions *)
method adjust_type : Reg.t -> Reg.t -> unit
method adjust_types : Reg.t array -> Reg.t array -> unit
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
+ environment -> Cmm.expression -> Reg.t array option
+ method emit_tail : environment -> 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_allocation_args : environment -> 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
+ : environment
-> nativeint
-> Debuginfo.t
-> Reg.t array option
method about_to_emit_call
- : (Ident.t, Reg.t array) Tbl.t
+ : environment
-> Mach.instruction_desc
-> Reg.t array
-> Reg.t array option
- method initial_env : unit -> (Ident.t, Reg.t array) Tbl.t
+ method initial_env : unit -> environment
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
+ -> env:environment
-> Mach.spacetime_shape option
val mutable instr_seq : Mach.instruction
+
end
val reset : unit -> unit
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 dbg = Debuginfo.none in
let open Cmm in
let initialize_direct_tail_call_points_and_return_node =
let new_node_encoded = Ident.create "new_node_encoded" in
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]),
+ [Cop (Caddi, [Cvar new_node; Cconst_int offset_in_bytes], dbg);
+ Cvar new_node_encoded], dbg),
init_code))
(Cvar new_node)
indexes
| _ ->
Clet (new_node_encoded,
(* Cf. [Encode_tail_caller_node] in the runtime. *)
- Cop (Cor, [Cvar new_node; Cconst_int 1]),
+ Cop (Cor, [Cvar new_node; Cconst_int 1], dbg),
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]),
+ Clet (node, Cop (Cload (Word_int, Asttypes.Mutable), [Cvar node_hole], dbg),
+ Clet (must_allocate_node,
+ Cop (Cand, [Cvar node; Cconst_int 1], dbg),
+ Cifthenelse (
+ Cop (Ccmpi Cne, [Cvar must_allocate_node; Cconst_int 1], dbg),
Cvar node,
Clet (is_new_node,
Clet (pc, Cconst_symbol function_name,
Cop (Cextcall ("caml_spacetime_allocate_node",
- [| Int |], false, Debuginfo.none, None),
+ [| Int |], false, None),
[Cconst_int (1 (* header *) + !index_within_node);
Cvar pc;
Cvar node_hole;
- ])),
- Clet (new_node, Cop (Cload Word_int, [Cvar node_hole]),
+ ],
+ dbg)),
+ Clet (new_node,
+ Cop (Cload (Word_int, Asttypes.Mutable), [Cvar node_hole], dbg),
if no_tail_calls then Cvar new_node
else
Cifthenelse (
- Cop (Ccmpi Ceq, [Cvar is_new_node; Cconst_int 0]),
+ Cop (Ccmpi Ceq, [Cvar is_new_node; Cconst_int 0], dbg),
Cvar new_node,
initialize_direct_tail_call_points_and_return_node))))))
a point to a location.
*)
Cop (Cextcall ("caml_spacetime_generate_profinfo", [| Int |],
- false, dbg, Some label),
+ false, Some label),
[Cvar address_of_profinfo;
- Cconst_int (index_within_node + 1)])
+ Cconst_int (index_within_node + 1)],
+ dbg)
in
(* Check if we have already allocated a profinfo value for this allocation
point with the current backtrace. If so, use that value; if not,
Cop (Caddi, [
Cvar node;
Cconst_int offset_into_node;
- ]),
- Clet (existing_profinfo, Cop (Cload Word_int, [Cvar address_of_profinfo]),
+ ], dbg),
+ Clet (existing_profinfo,
+ Cop (Cload (Word_int, Asttypes.Mutable), [Cvar address_of_profinfo],
+ dbg),
Clet (profinfo,
Cifthenelse (
- Cop (Ccmpi Cne, [Cvar existing_profinfo; Cconst_int 1 (* () *)]),
+ Cop (Ccmpi Cne, [Cvar existing_profinfo; Cconst_int 1 (* () *)], dbg),
Cvar existing_profinfo,
generate_new_profinfo),
Clet (existing_count,
- Cop (Cload Word_int, [
+ Cop (Cload (Word_int, Asttypes.Mutable), [
Cop (Caddi,
- [Cvar address_of_profinfo; Cconst_int Arch.size_addr])
- ]),
+ [Cvar address_of_profinfo; Cconst_int Arch.size_addr], dbg)
+ ], dbg),
Csequence (
Cop (Cstore (Word_int, Lambda.Assignment),
[Cop (Caddi,
- [Cvar address_of_profinfo; Cconst_int Arch.size_addr]);
+ [Cvar address_of_profinfo; Cconst_int Arch.size_addr], dbg);
Cop (Caddi, [
Cvar existing_count;
(* N.B. "*2" since the count is an OCaml integer.
The "1 +" is to count the value's header. *)
Cconst_int (2 * (1 + Nativeint.to_int num_words));
- ]);
- ]),
+ ], dbg);
+ ], dbg),
(* [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. *)
(* 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]))))))
+ Cop (Cxor, [Cvar profinfo; Cconst_natint value's_header], dbg))))))
type callee =
| Direct of string
| Direct _ | Indirect _ -> ()
end;
let place_within_node = Ident.create "place_within_node" in
+ let dbg = Debuginfo.none in
let open Cmm in
Clet (place_within_node,
- Cop (Caddi, [node; Cconst_int (index_within_node * Arch.size_addr)]),
+ Cop (Caddi, [node; Cconst_int (index_within_node * Arch.size_addr)], dbg),
(* The following code returns the address that is to be moved into the
(hard) node hole pointer register immediately before the call.
(That move is inserted in [Selectgen].) *)
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]))
+ [| Int |], false, None),
+ [callee; Cvar place_within_node; caller_node],
+ dbg))
class virtual instruction_selection = object (self)
inherit Selectgen.selector_generic as super
| Some reg -> Some reg
method private instrument_indirect_call ~env ~callee ~is_tail
- ~label_after =
+ ~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 env = Selectgen.env_add callee_ident [| callee |] env in
let instrumentation =
code_for_call
~node:(Lazy.force !spacetime_node)
in
disable_instrumentation <- false;
let node = Lazy.force !spacetime_node_ident in
- let node_reg = Tbl.find node env in
+ let node_reg = Selectgen.env_find node env in
self#insert_moves node_temp_reg node_reg
end
method! select_allocation_args env =
if self#can_instrument () then begin
- let regs = Tbl.find (Lazy.force !spacetime_node_ident) env in
+ let regs = Selectgen.env_find (Lazy.force !spacetime_node_ident) env in
match regs with
| [| reg |] -> [| reg |]
| _ -> failwith "Expected one register only for spacetime_node_ident"
method! initial_env () =
let env = super#initial_env () in
if Config.spacetime then
- Tbl.add (Lazy.force !spacetime_node_ident)
+ Selectgen.env_add (Lazy.force !spacetime_node_ident)
(self#regs_for Cmm.typ_int) env
else
env
Misc.fatal_error ("bad GC root " ^ Reg.name r)
| _ -> ())
live;
+ live_offset := List.sort_uniq (-) !live_offset;
frame_descriptors :=
{ fd_lbl = lbl;
fd_frame_size = frame_size();
method select_addressing _chunk = function
Cconst_symbol s ->
(Ibased(s, 0), Ctuple [])
- | Cop((Caddv | Cadda), [Cconst_symbol s; Cconst_int n]) ->
+ | Cop((Caddv | Cadda), [Cconst_symbol s; Cconst_int n], _) ->
(Ibased(s, n), Ctuple [])
- | Cop((Caddv | Cadda), [arg; Cconst_int n]) ->
+ | Cop((Caddv | Cadda), [arg; Cconst_int n], _) ->
(Iindexed n, arg)
- | Cop((Caddv | Cadda as op), [arg1; Cop(Caddi, [arg2; Cconst_int n])]) ->
- (Iindexed n, Cop(op, [arg1; arg2]))
+ | Cop((Caddv | Cadda as op),
+ [arg1; Cop(Caddi, [arg2; Cconst_int n], _)], dbg) ->
+ (Iindexed n, Cop(op, [arg1; arg2], dbg))
| arg ->
(Iindexed 0, arg)
method private iextcall (func, alloc) =
Iextcall { func; alloc; label_after = Cmm.new_label (); }
-method! select_operation op args =
+method! select_operation op args dbg =
match (op, args) with
(* For SPARC V7 multiplication, division and modulus are turned into
calls to C library routines.
| (Cmodi, _) ->
(self#iextcall(".rem", false), args)
| _ ->
- super#select_operation op args
+ super#select_operation op args dbg
(* Override insert_move_args to deal correctly with floating-point
arguments being passed into pairs of integer registers. *)
let (new_next, finally) = reload i.next Reg.Set.empty in
(instr_cons (Iloop(!final_body)) i.arg i.res new_next,
finally)
- | Icatch(nfail, body, handler) ->
- let new_set = ref Reg.Set.empty in
- reload_at_exit := (nfail, new_set) :: !reload_at_exit ;
+ | Icatch(rec_flag, handlers, body) ->
+ let new_sets = List.map
+ (fun (nfail, _) -> nfail, ref Reg.Set.empty) handlers in
+ let previous_reload_at_exit = !reload_at_exit in
+ reload_at_exit := new_sets @ !reload_at_exit ;
let (new_body, after_body) = reload body before in
- let at_exit = !new_set in
- reload_at_exit := List.tl !reload_at_exit ;
- let (new_handler, after_handler) = reload handler at_exit in
- let (new_next, finally) =
- reload i.next (Reg.Set.union after_body after_handler) in
- (instr_cons (Icatch(nfail, new_body, new_handler)) i.arg i.res new_next,
+ let rec fixpoint () =
+ let at_exits = List.map (fun (nfail, set) -> (nfail, !set)) new_sets in
+ let res =
+ List.map2 (fun (nfail', handler) (nfail, at_exit) ->
+ assert(nfail = nfail');
+ reload handler at_exit) handlers at_exits in
+ match rec_flag with
+ | Cmm.Nonrecursive ->
+ res
+ | Cmm.Recursive ->
+ let equal = List.for_all2 (fun (nfail', at_exit) (nfail, new_set) ->
+ assert(nfail = nfail');
+ Reg.Set.equal at_exit !new_set)
+ at_exits new_sets in
+ if equal
+ then res
+ else fixpoint ()
+ in
+ let res = fixpoint () in
+ reload_at_exit := previous_reload_at_exit;
+ let union = List.fold_left
+ (fun acc (_, after_handler) -> Reg.Set.union acc after_handler)
+ after_body res in
+ let (new_next, finally) = reload i.next union in
+ let new_handlers = List.map2
+ (fun (nfail, _) (new_handler, _) -> nfail, new_handler)
+ handlers res in
+ (instr_cons
+ (Icatch(rec_flag, new_handlers, new_body)) i.arg i.res new_next,
finally)
| Iexit nfail ->
let set = find_reload_at_exit nfail in
NB ter: is it the same thing for catch bodies ?
*)
+(* CR mshinwell for pchambart: Try to test the new algorithms for dealing
+ with Icatch. *)
let spill_at_exit = ref []
let find_spill_at_exit k =
try
- List.assoc k !spill_at_exit
+ let used, set = List.assoc k !spill_at_exit in
+ used := true;
+ set
with
| Not_found -> Misc.fatal_error "Spill.find_spill_at_exit"
let (new_ifso, before_ifso) = spill ifso at_join in
let (new_ifnot, before_ifnot) = spill ifnot at_join in
if
- !inside_loop || !inside_arm
+ !inside_loop || !inside_arm || !inside_catch
then
(instr_cons (Iifthenelse(test, new_ifso, new_ifnot))
i.arg i.res new_next,
inside_loop := saved_inside_loop;
(instr_cons (Iloop(!final_body)) i.arg i.res new_next,
!at_head)
- | Icatch(nfail, body, handler) ->
+ | Icatch(rec_flag, handlers, body) ->
let (new_next, at_join) = spill i.next finally in
- let (new_handler, at_exit) = spill handler at_join in
let saved_inside_catch = !inside_catch in
inside_catch := true ;
- spill_at_exit := (nfail, at_exit) :: !spill_at_exit ;
- let (new_body, before) = spill body at_join in
- spill_at_exit := List.tl !spill_at_exit;
+ let previous_spill_at_exit = !spill_at_exit in
+ let spill_at_exit_add at_exits = List.map2
+ (fun (nfail,_) at_exit -> nfail, (ref false, at_exit))
+ handlers at_exits
+ in
+ let rec fixpoint at_exits =
+ let spill_at_exit_add = spill_at_exit_add at_exits in
+ spill_at_exit := spill_at_exit_add @ !spill_at_exit;
+ let res =
+ List.map (fun (_, handler) -> spill handler at_join) handlers
+ in
+ spill_at_exit := previous_spill_at_exit;
+ match rec_flag with
+ | Cmm.Nonrecursive ->
+ res
+ | Cmm.Recursive ->
+ let equal =
+ List.for_all2
+ (fun (_new_handler, new_at_exit) (_, (used, at_exit)) ->
+ Reg.Set.equal at_exit new_at_exit || not !used)
+ res spill_at_exit_add in
+ if equal
+ then res
+ else fixpoint (List.map snd res)
+ in
+ let res = fixpoint (List.map (fun _ -> Reg.Set.empty) handlers) in
inside_catch := saved_inside_catch ;
- (instr_cons (Icatch(nfail, new_body, new_handler)) i.arg i.res new_next,
+ let spill_at_exit_add = spill_at_exit_add (List.map snd res) in
+ spill_at_exit := spill_at_exit_add @ !spill_at_exit;
+ let (new_body, before) = spill body at_join in
+ spill_at_exit := previous_spill_at_exit;
+ let new_handlers = List.map2
+ (fun (nfail, _) (handler, _) -> nfail, handler)
+ handlers res in
+ (instr_cons (Icatch(rec_flag, new_handlers, new_body))
+ i.arg i.res new_next,
before)
| Iexit nfail ->
(i, find_spill_at_exit nfail)
let (new_next, sub_next) = rename i.next (merge_substs sub sub_body i) in
(instr_cons (Iloop(new_body)) [||] [||] new_next,
sub_next)
- | Icatch(nfail, body, handler) ->
- let new_subst = ref None in
- exit_subst := (nfail, new_subst) :: !exit_subst ;
+ | Icatch(rec_flag, handlers, body) ->
+ let new_subst = List.map (fun (nfail, _) -> nfail, ref None)
+ handlers in
+ let previous_exit_subst = !exit_subst in
+ exit_subst := new_subst @ !exit_subst;
let (new_body, sub_body) = rename body sub in
- let sub_entry_handler = !new_subst in
- exit_subst := List.tl !exit_subst;
- let (new_handler, sub_handler) = rename handler sub_entry_handler in
- let (new_next, sub_next) =
- rename i.next (merge_substs sub_body sub_handler i.next) in
- (instr_cons (Icatch(nfail, new_body, new_handler)) [||] [||] new_next,
+ let res = List.map2 (fun (_, handler) (_, new_subst) -> rename handler !new_subst)
+ handlers new_subst in
+ exit_subst := previous_exit_subst;
+ let merged_subst =
+ List.fold_left (fun acc (_, sub_handler) ->
+ merge_substs acc sub_handler i.next)
+ sub_body res in
+ let (new_next, sub_next) = rename i.next merged_subst in
+ let new_handlers = List.map2 (fun (nfail, _) (handler, _) ->
+ (nfail, handler)) handlers res in
+ (instr_cons
+ (Icatch(rec_flag, new_handlers, new_body)) [||] [||] new_next,
sub_next)
| Iexit nfail ->
let r = find_exit_subst nfail in
let gen_size_id () = Ident.create "size"
let mk_let_cell id str ind body =
+ let dbg = Debuginfo.none in
let cell =
- Cop(Cload Word_int,[Cop(Cadda,[str;Cconst_int(Arch.size_int*ind)])]) in
+ Cop(Cload (Word_int, Asttypes.Mutable),
+ [Cop(Cadda,[str;Cconst_int(Arch.size_int*ind)], dbg)],
+ dbg) in
Clet(id, cell, body)
let mk_let_size id str body =
Clet(id, size, body)
let mk_cmp_gen cmp_op id nat ifso ifnot =
- let test = Cop (Ccmpi cmp_op, [ Cvar id; Cconst_natpointer nat ]) in
+ let dbg = Debuginfo.none in
+ let test =
+ Cop (Ccmpi cmp_op, [ Cvar id; Cconst_natpointer nat ], dbg)
+ in
Cifthenelse (test, ifso, ifnot)
let mk_lt = mk_cmp_gen Clt
In that latter case pattern len is string length-1 and is corrected.
*)
- let compile_by_size from_ind str default cases =
+ let compile_by_size dbg from_ind str default cases =
let size_cases =
List.map
(fun (len,cases) ->
(len,act))
(by_size cases) in
let id = gen_size_id () in
+ ignore dbg;
let switch = I.transl_switch (Cvar id) 1 max_int size_cases default in
mk_let_size id str switch
either on size or on first cell, using the
'least discriminant' heuristics.
*)
- let top_compile str default cases =
+ let top_compile debuginfo str default cases =
let a_len = count_arities_length cases
and a_fst = count_arities_first cases in
if a_len <= a_fst then begin
if dbg then pp_cases stderr "SIZE" cases ;
- compile_by_size 0 str default cases
+ compile_by_size debuginfo 0 str default cases
end else begin
if dbg then pp_cases stderr "FIRST COL" cases ;
let compile_size_rest str default cases =
- compile_by_size 1 str default cases in
+ compile_by_size debuginfo 1 str default cases in
match_oncell compile_size_rest str default 0 (by_cell cases)
end
| Cexit (_e,[]) -> k arg
| _ ->
let e = next_raise_count () in
- Ccatch (e,[],k (Cexit (e,[])),arg)
+ ccatch (e,[],k (Cexit (e,[])),arg)
- let compile str default cases =
+ let compile dbg str default cases =
(* We do not attempt to really optimise default=None *)
let cases,default = match cases,default with
| (_,e)::cases,None
List.rev_map
(fun (s,act) -> pat_of_string s,act)
cases in
- catch default (fun default -> top_compile str default cases)
+ catch default (fun default -> top_compile dbg str default cases)
end
module Make(I:I) : sig
(* Compile stringswitch (arg,cases,d)
Note: cases should not contain string duplicates *)
- val compile : Cmm.expression (* arg *) -> Cmm.expression option (* d *) ->
+ val compile : Debuginfo.t -> Cmm.expression (* arg *)
+ -> Cmm.expression option (* d *) ->
(string * Cmm.expression) list (* cases *)-> Cmm.expression
end
let ignore_debuginfo (_ : Debuginfo.t) = ()
let ignore_int (_ : int) = ()
let ignore_ident (_ : Ident.t) = ()
+let ignore_ident_option (_ : Ident.t option) = ()
let ignore_primitive (_ : Lambda.primitive) = ()
let ignore_string (_ : string) = ()
let ignore_int_array (_ : int array) = ()
ignore_debuginfo dbg
| Uclosure (functions, captured_variables) ->
List.iter loop captured_variables;
- List.iter (fun ({ Clambda. label; arity; params; body; dbg } as clos) ->
+ List.iter (fun (
+ { Clambda. label; arity; params; body; dbg; env; } as clos) ->
(match closure_environment_ident clos with
| None -> ()
| Some env_var ->
ignore_int arity;
ignore_ident_list params;
loop body;
- ignore_debuginfo dbg)
+ ignore_debuginfo dbg;
+ ignore_ident_option env)
functions
| Uoffset (expr, offset) ->
loop expr;
| Uclosure (functions, captured_variables) ->
ignore_ulambda_list captured_variables;
(* Start a new let stack for speed. *)
- List.iter (fun { Clambda. label; arity; params; body; dbg; } ->
+ List.iter (fun { Clambda. label; arity; params; body; dbg; env; } ->
ignore_function_label label;
ignore_int arity;
ignore_ident_list params;
let_stack := [];
loop body;
let_stack := [];
- ignore_debuginfo dbg)
+ ignore_debuginfo dbg;
+ ignore_ident_option env)
functions
| Uoffset (expr, offset) ->
(* [expr] should usually be a variable. *)
(* We say that an expression is "moveable" iff it has neither effects nor
coeffects. (See semantics_of_primitives.mli.)
*)
-type moveable = Fixed | Constant | Moveable | Moveable_not_into_loops
+type moveable = Fixed | Constant | Moveable
let both_moveable a b =
match a, b with
| 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, Constant
| Fixed, Moveable
- | Fixed, Moveable_not_into_loops
| Fixed, Fixed -> Fixed
let primitive_moveable (prim : Lambda.primitive)
| Arbitrary_effects, No_coeffects
| Arbitrary_effects, Has_coeffects -> Fixed
-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
- identifiers previously moveable, but not into loops, are now fixed. *)
-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)
+type moveable_for_env = Constant | Moveable
(** Eliminate, through substitution, [let]-bindings of linear variables with
moveable defining expressions. *)
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 ->
let moveable : moveable =
if Ident.Set.mem id ident_info.assigned then
let functions =
List.map (fun (ufunction : Clambda.ufunction) ->
{ ufunction with
- body = un_anf ident_info (going_into_loop env) ufunction.body;
+ body = un_anf ident_info env ufunction.body;
})
functions
in
- let variables_bound_by_the_closure, moveable =
- un_anf_list_and_moveable ident_info env variables_bound_by_the_closure
+ let variables_bound_by_the_closure =
+ un_anf_list ident_info env variables_bound_by_the_closure
in
- Uclosure (functions, variables_bound_by_the_closure),
- both_moveable moveable Moveable_not_into_loops
+ Uclosure (functions, variables_bound_by_the_closure), Fixed
| Uoffset (clam, n) ->
let clam, moveable = un_anf_and_moveable ident_info env clam in
Uoffset (clam, n), both_moveable Moveable moveable
let is_used = Ident.Set.mem id ident_info.used in
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, _ ->
+ | (Constant | Moveable), _, false, _ ->
(* A moveable expression that is never used may be eliminated. *)
un_anf_and_moveable ident_info env body
| Constant, _, true, false
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, 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. *)
- | (Constant | Moveable | Moveable_not_into_loops), _, _, true
+ | (Constant | Moveable), _, _, true
(* Constant or Moveable but assigned. *)
- | (Moveable | Moveable_not_into_loops), false, _, _
+ | Moveable, false, _, _
(* Moveable but not used linearly. *)
| Fixed, _, _, _ ->
let body, body_moveable = un_anf_and_moveable ident_info env body in
let e2 = un_anf ident_info env e2 in
Usequence (e1, e2), Fixed
| Uwhile (cond, body) ->
- let env = going_into_loop env in
let cond = un_anf ident_info env cond in
let body = un_anf ident_info env body in
Uwhile (cond, body), Fixed
| Ufor (id, low, high, direction, body) ->
let low = un_anf ident_info env low in
let high = un_anf ident_info env high in
- let body = un_anf ident_info (going_into_loop env) body in
+ let body = un_anf ident_info env body in
Ufor (id, low, high, direction, body), Fixed
| Uassign (id, expr) ->
let expr = un_anf ident_info env expr in
+afl.o: afl.c ../byterun/caml/misc.h ../byterun/caml/config.h \
+ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+ ../byterun/caml/mlvalues.h ../byterun/caml/osdeps.h
alloc.o: alloc.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/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 spacetime.h ../byterun/caml/io.h \
- ../byterun/caml/stack.h
+ ../byterun/caml/signals.h ../byterun/caml/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 \
debugger.o: debugger.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/debugger.h
+ ../byterun/caml/debugger.h ../byterun/caml/osdeps.h
dynlink.o: dynlink.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/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/version.h
+ ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
+ ../byterun/caml/version.h
natdynlink.o: natdynlink.c ../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 spacetime.h \
- ../byterun/caml/io.h ../byterun/caml/stack.h
+ ../byterun/caml/address_class.h ../byterun/caml/prims.h \
+ ../byterun/caml/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 \
../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 ../byterun/caml/stack.h spacetime.h \
+ signals_osdep.h ../byterun/caml/stack.h ../byterun/caml/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/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
+ ../byterun/caml/osdeps.h ../byterun/caml/roots.h \
+ ../byterun/caml/signals.h ../byterun/caml/stack.h \
+ ../byterun/caml/sys.h ../byterun/caml/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/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
+ ../byterun/caml/sys.h ../byterun/caml/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/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
+ ../byterun/caml/stack.h ../byterun/caml/sys.h \
+ ../byterun/caml/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 \
../byterun/caml/misc.h ../byterun/caml/exec.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/startup_aux.h
+ ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
+ ../byterun/caml/startup_aux.h
str.o: str.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/freelist.h ../byterun/caml/memory.h \
../byterun/caml/gc.h ../byterun/caml/minor_gc.h \
../byterun/caml/address_class.h ../byterun/caml/weak.h
+afl.p.o: afl.c ../byterun/caml/misc.h ../byterun/caml/config.h \
+ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+ ../byterun/caml/mlvalues.h ../byterun/caml/osdeps.h
alloc.p.o: alloc.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/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 spacetime.h ../byterun/caml/io.h \
- ../byterun/caml/stack.h
+ ../byterun/caml/signals.h ../byterun/caml/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 \
debugger.p.o: debugger.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/debugger.h
+ ../byterun/caml/debugger.h ../byterun/caml/osdeps.h
dynlink.p.o: dynlink.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/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/version.h
+ ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
+ ../byterun/caml/version.h
natdynlink.p.o: natdynlink.c ../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 spacetime.h \
- ../byterun/caml/io.h ../byterun/caml/stack.h
+ ../byterun/caml/address_class.h ../byterun/caml/prims.h \
+ ../byterun/caml/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 \
../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 ../byterun/caml/stack.h spacetime.h \
+ signals_osdep.h ../byterun/caml/stack.h ../byterun/caml/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/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
+ ../byterun/caml/osdeps.h ../byterun/caml/roots.h \
+ ../byterun/caml/signals.h ../byterun/caml/stack.h \
+ ../byterun/caml/sys.h ../byterun/caml/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/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
+ ../byterun/caml/sys.h ../byterun/caml/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/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
+ ../byterun/caml/stack.h ../byterun/caml/sys.h \
+ ../byterun/caml/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 \
../byterun/caml/misc.h ../byterun/caml/exec.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/startup_aux.h
+ ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
+ ../byterun/caml/startup_aux.h
str.p.o: str.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/freelist.h ../byterun/caml/memory.h \
../byterun/caml/gc.h ../byterun/caml/minor_gc.h \
../byterun/caml/address_class.h ../byterun/caml/weak.h
+afl.d.o: afl.c ../byterun/caml/misc.h ../byterun/caml/config.h \
+ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+ ../byterun/caml/mlvalues.h ../byterun/caml/osdeps.h
alloc.d.o: alloc.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/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 spacetime.h ../byterun/caml/io.h \
- ../byterun/caml/stack.h
+ ../byterun/caml/signals.h ../byterun/caml/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 \
debugger.d.o: debugger.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/debugger.h
+ ../byterun/caml/debugger.h ../byterun/caml/osdeps.h
dynlink.d.o: dynlink.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/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/version.h
+ ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
+ ../byterun/caml/version.h
natdynlink.d.o: natdynlink.c ../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 spacetime.h \
- ../byterun/caml/io.h ../byterun/caml/stack.h
+ ../byterun/caml/address_class.h ../byterun/caml/prims.h \
+ ../byterun/caml/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 \
../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 ../byterun/caml/stack.h spacetime.h \
+ signals_osdep.h ../byterun/caml/stack.h ../byterun/caml/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/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
+ ../byterun/caml/osdeps.h ../byterun/caml/roots.h \
+ ../byterun/caml/signals.h ../byterun/caml/stack.h \
+ ../byterun/caml/sys.h ../byterun/caml/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/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
+ ../byterun/caml/sys.h ../byterun/caml/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/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
+ ../byterun/caml/stack.h ../byterun/caml/sys.h \
+ ../byterun/caml/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 \
../byterun/caml/misc.h ../byterun/caml/exec.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/startup_aux.h
+ ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
+ ../byterun/caml/startup_aux.h
str.d.o: str.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/freelist.h ../byterun/caml/memory.h \
../byterun/caml/gc.h ../byterun/caml/minor_gc.h \
../byterun/caml/address_class.h ../byterun/caml/weak.h
+afl.i.o: afl.c ../byterun/caml/misc.h ../byterun/caml/config.h \
+ ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+ ../byterun/caml/mlvalues.h ../byterun/caml/osdeps.h
alloc.i.o: alloc.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/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 spacetime.h ../byterun/caml/io.h \
- ../byterun/caml/stack.h
+ ../byterun/caml/signals.h ../byterun/caml/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 \
debugger.i.o: debugger.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/debugger.h
+ ../byterun/caml/debugger.h ../byterun/caml/osdeps.h
dynlink.i.o: dynlink.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/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/version.h
+ ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
+ ../byterun/caml/version.h
natdynlink.i.o: natdynlink.c ../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 spacetime.h \
- ../byterun/caml/io.h ../byterun/caml/stack.h
+ ../byterun/caml/address_class.h ../byterun/caml/prims.h \
+ ../byterun/caml/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 \
../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 ../byterun/caml/stack.h spacetime.h \
+ signals_osdep.h ../byterun/caml/stack.h ../byterun/caml/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/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
+ ../byterun/caml/osdeps.h ../byterun/caml/roots.h \
+ ../byterun/caml/signals.h ../byterun/caml/stack.h \
+ ../byterun/caml/sys.h ../byterun/caml/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/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
+ ../byterun/caml/sys.h ../byterun/caml/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/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
+ ../byterun/caml/stack.h ../byterun/caml/sys.h \
+ ../byterun/caml/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 \
../byterun/caml/misc.h ../byterun/caml/exec.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/startup_aux.h
+ ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
+ ../byterun/caml/startup_aux.h
str.i.o: str.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 \
include ../config/Makefile
-CC=$(NATIVECC)
-FLAGS=-I../byterun -DCAML_NAME_SPACE -DNATIVE_CODE \
- -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)
-PICFLAGS=$(FLAGS) $(SHAREDCCCOMPOPTS) $(NATIVECCCOMPOPTS)
+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 startup_aux.c \
+ backtrace.c afl.c
-COBJS=startup_aux.o startup.o \
- main.o fail.o roots.o globroots.o signals.o signals_asm.o \
- freelist.o misc.o major_gc.o minor_gc.o memory.o alloc.o compare.o ints.o \
- floats.o str.o array.o io.o extern.o intern.o hash.o sys.o parsing.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 \
- spacetime.o spacetime_snapshot.o spacetime_offline.o
+INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
-ASMOBJS=$(ARCH).o
+CC=$(NATIVECC)
-OBJS=$(COBJS) $(ASMOBJS)
-DOBJS=$(COBJS:.o=.d.o) $(ASMOBJS)
-IOBJS=$(COBJS:.o=.i.o) $(ASMOBJS)
-POBJS=$(COBJS:.o=.p.o) $(ASMOBJS:.o=.p.o)
-PICOBJS=$(COBJS:.o=.pic.o) $(ASMOBJS:.o=.pic.o)
+ifeq "$(UNIX_OR_WIN32)" "win32"
+LN = cp
+else
+LN = ln -s
+endif
-all: libasmrun.a all-$(RUNTIMED) all-$(PROFILING) all-$(SHARED)
+FLAGS=\
+ -I../byterun \
+ -DNATIVE_CODE -DTARGET_$(ARCH)
-ifeq "$(RUNTIMEI)" "true"
-all: libasmruni.a
+ifeq "$(UNIX_OR_WIN32)" "unix"
+FLAGS += -DMODEL_$(MODEL)
endif
-libasmrun.a: $(OBJS)
- rm -f libasmrun.a
- $(ARCMD) rc libasmrun.a $(OBJS)
- $(RANLIB) libasmrun.a
+FLAGS += -DSYS_$(SYSTEM) \
+ $(NATIVECCCOMPOPTS) $(IFLEXDIR) \
+ $(LIBUNWIND_INCLUDE_FLAGS)
-all-noruntimed:
-.PHONY: all-noruntimed
+ifeq "$(TOOLCHAIN)" "msvc"
+DFLAGS=$(FLAGS) -DDEBUG
+PFLAGS=$(FLAGS) -DPROFILING $(NATIVECCPROFOPTS)
+OUTPUTOBJ = -Fo
+ASMOBJS=$(ARCH)nt.$(O)
+else
+DFLAGS=$(FLAGS) -g -DDEBUG
+PFLAGS=$(FLAGS) -pg -DPROFILING $(NATIVECCPROFOPTS)
+OUTPUTOBJ = -o
+ASMOBJS=$(ARCH).$(O)
+endif
-all-runtimed: libasmrund.a
-.PHONY: all-runtimed
+IFLAGS=$(FLAGS) -DCAML_INSTR
+PICFLAGS=$(FLAGS) $(SHAREDCCCOMPOPTS)
-libasmrund.a: $(DOBJS)
- rm -f libasmrund.a
- $(ARCMD) rc libasmrund.a $(DOBJS)
- $(RANLIB) libasmrund.a
+ASPPFLAGS = -DSYS_$(SYSTEM)
+ifeq "$(UNIX_OR_WIN32)" "unix"
+ASPPFLAGS += -DMODEL_$(MODEL)
+CFLAGS=$(FLAGS) -g
+else
+CFLAGS=$(FLAGS)
+endif
-libasmruni.a: $(IOBJS)
- rm -f $@
- $(ARCMD) rc $@ $^
- $(RANLIB) $@
+COBJS=startup_aux.$(O) startup.$(O) main.$(O) fail.$(O) \
+ roots.$(O) signals.$(O) signals_asm.$(O) misc.$(O) freelist.$(O) \
+ major_gc.$(O) minor_gc.$(O) memory.$(O) alloc.$(O) compare.$(O) \
+ ints.$(O) floats.$(O) str.$(O) array.$(O) io.$(O) extern.$(O) \
+ intern.$(O) hash.$(O) sys.$(O) parsing.$(O) gc_ctrl.$(O) \
+ terminfo.$(O) md5.$(O) obj.$(O) lexing.$(O) $(UNIX_OR_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) spacetime.$(O) spacetime_snapshot.$(O) \
+ spacetime_offline.$(O) afl.$(O)
-all-noprof:
+OBJS=$(COBJS) $(ASMOBJS)
-all-prof: libasmrunp.a
+DOBJS=$(COBJS:.$(O)=.d.$(O)) $(ASMOBJS)
+IOBJS=$(COBJS:.$(O)=.i.$(O)) $(ASMOBJS)
+POBJS=$(COBJS:.$(O)=.p.$(O)) $(ASMOBJS:.$(O)=.p.$(O))
+PICOBJS=$(COBJS:.$(O)=.pic.$(O)) $(ASMOBJS:.$(O)=.pic.$(O))
-libasmrunp.a: $(POBJS)
- rm -f libasmrunp.a
- $(ARCMD) rc libasmrunp.a $(POBJS)
- $(RANLIB) libasmrunp.a
+TARGETS = libasmrun.$(A)
-all-noshared:
+ifeq "$(RUNTIMED)" "true"
+TARGETS += libasmrund.$(A)
+endif
-all-shared: libasmrun_pic.a libasmrun_shared.so
+ifeq "$(RUNTIMEI)" "true"
+TARGETS += libasmruni.$(A)
+endif
-libasmrun_pic.a: $(PICOBJS)
- rm -f libasmrun_pic.a
- $(ARCMD) rc libasmrun_pic.a $(PICOBJS)
- $(RANLIB) libasmrun_pic.a
+ifeq "$(PROFILING)" "true"
+TARGETS += libasmrunp.$(A)
+endif
-libasmrun_shared.so: $(PICOBJS)
- $(MKDLL) -o libasmrun_shared.so $(PICOBJS) $(NATIVECCLIBS)
+ifeq "$(UNIX_OR_WIN32)" "unix"
+ifeq "$(SUPPORTS_SHARED_LIBRARIES)" "true"
+TARGETS += libasmrun_pic.$(A) libasmrun_shared.$(SO)
+endif
+endif
-INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
+.PHONY: all
+all: $(TARGETS)
-install::
- cp libasmrun.a $(INSTALL_LIBDIR)/libasmrun.a
- cd $(INSTALL_LIBDIR); $(RANLIB) libasmrun.a
-.PHONY: install-default
+libasmrun.$(A): $(OBJS)
+ $(call MKLIB,$@, $^)
-ifeq "$(RUNTIMED)" "runtimed"
-install::
- cp libasmrund.a $(INSTALL_LIBDIR)/libasmrund.a
- cd $(INSTALL_LIBDIR); $(RANLIB) libasmrund.a
-endif
+libasmrund.$(A): $(DOBJS)
+ $(call MKLIB,$@, $^)
-ifeq "$(RUNTIMEI)" "true"
-install::
- cp libasmruni.a $(INSTALL_LIBDIR)/libasmruni.a
- cd $(INSTALL_LIBDIR); $(RANLIB) libasmruni.a
-endif
+libasmruni.$(A): $(IOBJS)
+ $(call MKLIB,$@, $^)
-ifeq "$(PROFILING)" "prof"
-install::
- cp libasmrunp.a $(INSTALL_LIBDIR)/libasmrunp.a
- cd $(INSTALL_LIBDIR); $(RANLIB) libasmrunp.a
-else
-install::
- rm -f $(INSTALL_LIBDIR)/libasmrunp.a
- ln -s libasmrun.a $(INSTALL_LIBDIR)/libasmrunp.a
-endif
+libasmrunp.$(A): $(POBJS)
+ $(call MKLIB,$@, $^)
-ifeq "$(SHARED)" "shared"
-install::
- cp libasmrun_pic.a $(INSTALL_LIBDIR)/libasmrun_pic.a
- cd $(INSTALL_LIBDIR); $(RANLIB) libasmrunp.a
- cp libasmrun_shared.so $(INSTALL_LIBDIR)/libasmrun_shared.so
-endif
+libasmrun_pic.$(A): $(PICOBJS)
+ $(call MKLIB,$@, $^)
-main.c: ../byterun/main.c
- ln -s ../byterun/main.c main.c
-startup_aux.c: ../byterun/startup_aux.c
- ln -s ../byterun/startup_aux.c startup_aux.c
-backtrace.c: ../byterun/backtrace.c
- ln -s ../byterun/backtrace.c backtrace.c
-misc.c: ../byterun/misc.c
- ln -s ../byterun/misc.c misc.c
-freelist.c: ../byterun/freelist.c
- ln -s ../byterun/freelist.c freelist.c
-major_gc.c: ../byterun/major_gc.c
- ln -s ../byterun/major_gc.c major_gc.c
-minor_gc.c: ../byterun/minor_gc.c
- ln -s ../byterun/minor_gc.c minor_gc.c
-memory.c: ../byterun/memory.c
- ln -s ../byterun/memory.c memory.c
-alloc.c: ../byterun/alloc.c
- ln -s ../byterun/alloc.c alloc.c
-array.c: ../byterun/array.c
- ln -s ../byterun/array.c array.c
-compare.c: ../byterun/compare.c
- ln -s ../byterun/compare.c compare.c
-ints.c: ../byterun/ints.c
- ln -s ../byterun/ints.c ints.c
-floats.c: ../byterun/floats.c
- ln -s ../byterun/floats.c floats.c
-str.c: ../byterun/str.c
- ln -s ../byterun/str.c str.c
-io.c: ../byterun/io.c
- ln -s ../byterun/io.c io.c
-extern.c: ../byterun/extern.c
- ln -s ../byterun/extern.c extern.c
-intern.c: ../byterun/intern.c
- ln -s ../byterun/intern.c intern.c
-hash.c: ../byterun/hash.c
- ln -s ../byterun/hash.c hash.c
-sys.c: ../byterun/sys.c
- ln -s ../byterun/sys.c sys.c
-parsing.c: ../byterun/parsing.c
- ln -s ../byterun/parsing.c parsing.c
-gc_ctrl.c: ../byterun/gc_ctrl.c
- ln -s ../byterun/gc_ctrl.c gc_ctrl.c
-terminfo.c: ../byterun/terminfo.c
- ln -s ../byterun/terminfo.c terminfo.c
-md5.c: ../byterun/md5.c
- ln -s ../byterun/md5.c md5.c
-obj.c: ../byterun/obj.c
- ln -s ../byterun/obj.c obj.c
-lexing.c: ../byterun/lexing.c
- ln -s ../byterun/lexing.c lexing.c
-printexc.c: ../byterun/printexc.c
- ln -s ../byterun/printexc.c printexc.c
-callback.c: ../byterun/callback.c
- ln -s ../byterun/callback.c callback.c
-weak.c: ../byterun/weak.c
- ln -s ../byterun/weak.c weak.c
-compact.c: ../byterun/compact.c
- ln -s ../byterun/compact.c compact.c
-finalise.c: ../byterun/finalise.c
- ln -s ../byterun/finalise.c finalise.c
-custom.c: ../byterun/custom.c
- ln -s ../byterun/custom.c custom.c
-meta.c: ../byterun/meta.c
- ln -s ../byterun/meta.c meta.c
-globroots.c: ../byterun/globroots.c
- ln -s ../byterun/globroots.c globroots.c
-$(UNIX_OR_WIN32).c: ../byterun/$(UNIX_OR_WIN32).c
- ln -s ../byterun/$(UNIX_OR_WIN32).c $(UNIX_OR_WIN32).c
-dynlink.c: ../byterun/dynlink.c
- ln -s ../byterun/dynlink.c dynlink.c
-signals.c: ../byterun/signals.c
- ln -s ../byterun/signals.c signals.c
-debugger.c: ../byterun/debugger.c
- ln -s ../byterun/debugger.c debugger.c
+libasmrun_shared.$(SO): $(PICOBJS)
+ $(MKDLL) -o $@ $^ $(NATIVECCLIBS)
-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 startup_aux.c backtrace.c
+.PHONY: install
+install:
+ cp $(TARGETS) "$(INSTALL_LIBDIR)"
-clean::
- rm -f $(LINKEDFILES)
+$(LINKEDFILES): %.c: ../byterun/%.c
+ $(LN) $< $@
-%.d.o: %.c
- $(CC) -c $(DFLAGS) -o $@ $<
+%.d.$(O): %.c
+ $(CC) -c $(DFLAGS) $(OUTPUTOBJ)$@ $<
-%.i.o : %.c
- $(CC) -c $(IFLAGS) -o $@ $<
+%.i.$(O): %.c
+ $(CC) -c $(IFLAGS) $(OUTPUTOBJ)$@ $<
-%.p.o: %.c
- $(CC) -c $(PFLAGS) -o $@ $<
+%.p.$(O): %.c
+ $(CC) -c $(PFLAGS) $(OUTPUTOBJ)$@ $<
-%.pic.o: %.c
- $(CC) -c $(PICFLAGS) -o $@ $<
+%.pic.$(O): %.c
+ $(CC) -c $(PICFLAGS) $(OUTPUTOBJ)$@ $<
+
+%.$(O): %.c
+ $(CC) $(CFLAGS) -c $<
%.o: %.S
- $(ASPP) -DSYS_$(SYSTEM) -DMODEL_$(MODEL) -o $@ $< || \
+ $(ASPP) $(ASPPFLAGS) -o $@ $< || \
{ echo "If your assembler produced syntax errors, it is probably";\
echo "unhappy with the preprocessor. Check your assembler, or";\
echo "try producing $*.o by hand.";\
exit 2; }
%.p.o: %.S
- $(ASPP) -DSYS_$(SYSTEM) -DMODEL_$(MODEL) $(ASPPPROFFLAGS) -o $@ $<
+ $(ASPP) $(ASPPFLAGS) $(ASPPPROFFLAGS) -o $@ $<
%.pic.o: %.S
- $(ASPP) -DSYS_$(SYSTEM) -DMODEL_$(MODEL) $(SHAREDCCCOMPOPTS) -o $@ $<
+ $(ASPP) $(ASPPFLAGS) $(SHAREDCCCOMPOPTS) -o $@ $<
-%.o: %.s
- $(ASPP) -DSYS_$(SYSTEM) -o $@ $<
+%.obj: %.asm
+ $(ASM)$@ $<
-%.p.o: %.s
- $(ASPP) -DSYS_$(SYSTEM) $(ASPPPROFFLAGS) -o $@ $<
+%.pic.obj: %.asm
+ $(ASM)$@ $<
-%.pic.o: %.s
- $(ASPP) -DSYS_$(SYSTEM) $(SHAREDCCCOMPOPTS) -o $@ $<
+.PHONY: clean
+clean:
+ rm -f $(LINKEDFILES)
+ rm -f *.$(O) *.$(A) *.$(SO)
-clean::
- rm -f *.o *.a *.so *~
+.PHONY: distclean
+distclean: clean
+ rm -r *~
-depend: $(COBJS:.o=.c) ${LINKEDFILES}
+ifneq "$(TOOLCHAIN)" "msvc"
+.PHONY: depend
+depend: $(COBJS:.$(O)=.c) $(LINKEDFILES)
$(CC) -MM $(FLAGS) *.c > .depend
$(CC) -MM $(FLAGS) -DPROFILING *.c | sed -e 's/\.o/.p.o/' >> .depend
$(CC) -MM $(FLAGS) -DDEBUG *.c | sed -e 's/\.o/.d.o/' >> .depend
$(CC) -MM $(FLAGS) -DCAML_INSTR *.c | sed -e 's/\.o/.i.o/' >> .depend
+endif
+
+ifeq "$(UNIX_OR_WIN32)" "win32"
+.depend.nt: .depend
+ sed -e 's/\.o/.$(O)/g' .depend > .depend.nt
+
+include .depend.nt
+else
include .depend
+endif
#* *
#**************************************************************************
-include ../config/Makefile
-
-CC=$(NATIVECC)
-CFLAGS=-I../byterun -DNATIVE_CODE -DTARGET_$(ARCH) -DSYS_$(SYSTEM) \
- $(NATIVECCCOMPOPTS)
-
-COBJS=startup_aux.$(O) startup.$(O) \
- main.$(O) fail.$(O) roots.$(O) signals.$(O) signals_asm.$(O)\
- misc.$(O) freelist.$(O) major_gc.$(O) minor_gc.$(O) memory.$(O) alloc.$(O) \
- compare.$(O) ints.$(O) floats.$(O) str.$(O) array.$(O) io.$(O) extern.$(O) \
- intern.$(O) hash.$(O) sys.$(O) parsing.$(O) gc_ctrl.$(O) terminfo.$(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) \
- 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 \
- parsing.c gc_ctrl.c terminfo.c md5.c obj.c lexing.c printexc.c callback.c \
- weak.c compact.c meta.c finalise.c custom.c main.c globroots.c \
- dynlink.c signals.c debugger.c startup_aux.c backtrace.c
-
-ifeq ($(TOOLCHAIN),mingw)
-ASMOBJS=$(ARCH).o
-else
-ASMOBJS=$(ARCH)nt.obj
-endif
-
-OBJS=$(COBJS) $(ASMOBJS)
-
-all: libasmrun.$(A)
-
-libasmrun.$(A): $(OBJS)
- $(call MKLIB,libasmrun.$(A), $(OBJS))
-
-i386nt.obj: i386nt.asm
- $(ASM)i386nt.obj i386nt.asm
-
-amd64nt.obj: amd64nt.asm
- $(ASM)amd64nt.obj amd64nt.asm
-
-i386.o: i386.S
- $(ASPP) -DSYS_$(SYSTEM) i386.S
-
-amd64.o: amd64.S
- $(ASPP) -DSYS_$(SYSTEM) amd64.S
-
-INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
-
-install:
- cp libasmrun.$(A) "$(INSTALL_LIBDIR)"
-
-$(LINKEDFILES): %.c: ../byterun/%.c
- cp ../byterun/$*.c $*.c
-
-# Need special compilation rule so as not to do -I../byterun
-win32.$(O): ../byterun/win32.c
- $(CC) -c $(NATIVECCCOMPOPTS) -DNATIVE_CODE $(IFLEXDIR) \
- ../byterun/win32.c
-
-%.$(O): %.c
- $(CC) $(CFLAGS) -c $<
-
-clean::
- rm -f $(LINKEDFILES)
-
-clean::
- rm -f *.$(O) *.$(A) *~
-
-.depend.nt: .depend
- sed -e 's/\.o/.$(O)/g' .depend > .depend.nt
-
-include .depend.nt
+include Makefile
CFI_ADJUST(8)
RECORD_STACK_FRAME(8)
#ifdef WITH_FRAME_POINTERS
- /* Do we need 16-byte alignment here ? */
+ /* ensure 16 byte alignment by subq + enter using 16-bytes, PR#7417 */
+ subq $8, %rsp; CFI_ADJUST (8)
ENTER_FUNCTION
#endif
call LBL(caml_call_gc)
#ifdef WITH_FRAME_POINTERS
+ /* ensure 16 byte alignment by leave + addq using 16-bytes PR#7417 */
LEAVE_FUNCTION
+ addq $8, %rsp; CFI_ADJUST (-8)
#endif
popq %rax; CFI_ADJUST(-8) /* recover desired size */
jmp LBL(caml_allocN)
/* Try again */
b 1b
CFI_ENDPROC
- .type caml_alloc2, %function
- .size caml_alloc2, .-caml_alloc2
+ .type caml_alloc3, %function
+ .size caml_alloc3, .-caml_alloc3
.align 2
.globl caml_allocN
}
}
+int caml_alloc_backtrace_buffer(void){
+ Assert(caml_backtrace_pos == 0);
+ caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE
+ * sizeof(backtrace_slot));
+ if (caml_backtrace_buffer == NULL) return -1;
+ return 0;
+}
+
/* Stores the return addresses contained in the given stack fragment
into the backtrace array ; this version is performance-sensitive as
it is called at each [raise] in a program compiled with [-g], so we
caml_backtrace_pos = 0;
caml_backtrace_last_exn = exn;
}
- if (caml_backtrace_buffer == NULL) {
- Assert(caml_backtrace_pos == 0);
- caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE
- * sizeof(backtrace_slot));
- if (caml_backtrace_buffer == NULL) return;
- }
+
+ if (caml_backtrace_buffer == NULL && caml_alloc_backtrace_buffer() == -1)
+ return;
/* iterate on each frame */
while (1) {
const char* descr = String_val(v_descr);
value orig_v = v;
if (v == (value) 0) {
- fprintf(stderr, "Access to field %lld of NULL: %s\n",
- (ARCH_UINT64_TYPE) Long_val(pos), descr);
+ fprintf(stderr,
+ "Access to field %" ARCH_INT64_PRINTF_FORMAT
+ "u of NULL: %s\n", (ARCH_UINT64_TYPE) Long_val(pos), descr);
abort();
}
if (!Is_block(v)) {
fprintf(stderr,
- "Access to field %lld of non-boxed value %p is illegal: %s\n",
+ "Access to field %" ARCH_INT64_PRINTF_FORMAT
+ "u of non-boxed value %p is illegal: %s\n",
(ARCH_UINT64_TYPE) Long_val(pos), (void*) v, descr);
abort();
}
assert(Long_val(pos) >= 0);
if (Long_val(pos) >= Wosize_val(v)) {
fprintf(stderr,
- "Access to field %lld of value %p of size %lld is illegal: %s\n",
+ "Access to field %" ARCH_INT64_PRINTF_FORMAT
+ "u of value %p of size %" ARCH_INT64_PRINTF_FORMAT "u is illegal: %s\n",
(ARCH_UINT64_TYPE) Long_val(pos), (void*) v,
(ARCH_UINT64_TYPE) Wosize_val(v),
descr);
caml_raise_with_string((value) caml_exn_Failure, msg);
}
+void caml_failwith_value (value msg)
+{
+ caml_raise_with_arg((value) caml_exn_Failure, msg);
+}
+
void caml_invalid_argument (char const *msg)
{
caml_raise_with_string((value) caml_exn_Invalid_argument, msg);
}
+void caml_invalid_argument_value (value msg)
+{
+ caml_raise_with_arg((value) caml_exn_Invalid_argument, msg);
+}
+
void caml_raise_out_of_memory(void)
{
caml_raise_constant((value) caml_exn_Out_of_memory);
#include "caml/fail.h"
#include "caml/signals.h"
#ifdef WITH_SPACETIME
-#include "spacetime.h"
+#include "caml/spacetime.h"
#endif
#include "caml/hooks.h"
#include <stdio.h>
#include <string.h>
+#include <limits.h>
+
+#define Handle_val(v) (*((void **) Data_abstract_val(v)))
+static value Val_handle(void* handle) {
+ value res = caml_alloc_small(1, Abstract_tag);
+ Handle_val(res) = handle;
+ return res;
+}
static void *getsym(void *handle, char *module, char *name){
char *fullname = caml_strconcat(3, "caml", module, name);
CAMLprim value caml_natdynlink_getmap(value unit)
{
- return (value)caml_globals_map;
+ return caml_input_value_from_block(caml_globals_map, INT_MAX);
}
CAMLprim value caml_natdynlink_globals_inited(value unit)
CAMLprim value caml_natdynlink_open(value filename, value global)
{
- CAMLparam1 (filename);
- CAMLlocal1 (res);
+ CAMLparam2 (filename, global);
+ CAMLlocal3 (res, handle, header);
void *sym;
- void *handle;
+ void *dlhandle;
char *p;
/* TODO: dlclose in case of error... */
p = caml_strdup(String_val(filename));
caml_enter_blocking_section();
- handle = caml_dlopen(p, 1, Int_val(global));
+ dlhandle = caml_dlopen(p, 1, Int_val(global));
caml_leave_blocking_section();
caml_stat_free(p);
- if (NULL == handle)
- CAMLreturn(caml_copy_string(caml_dlerror()));
+ if (NULL == dlhandle)
+ caml_failwith(caml_dlerror());
- sym = caml_dlsym(handle, "caml_plugin_header");
+ sym = caml_dlsym(dlhandle, "caml_plugin_header");
if (NULL == sym)
- CAMLreturn(caml_copy_string("not an OCaml plugin"));
+ caml_failwith("not an OCaml plugin");
+
+ handle = Val_handle(dlhandle);
+ header = caml_input_value_from_block(sym, INT_MAX);
res = caml_alloc_tuple(2);
- Field(res, 0) = (value) handle;
- Field(res, 1) = (value) (sym);
+ Field(res, 0) = handle;
+ Field(res, 1) = header;
CAMLreturn(res);
}
-CAMLprim value caml_natdynlink_run(void *handle, value symbol) {
- CAMLparam1 (symbol);
+CAMLprim value caml_natdynlink_run(value handle_v, value symbol) {
+ CAMLparam2 (handle_v, symbol);
CAMLlocal1 (result);
void *sym,*sym2;
+ void* handle = Handle_val(handle_v);
struct code_fragment * cf;
#define optsym(n) getsym(handle,unit,n)
CAMLprim value caml_natdynlink_run_toplevel(value filename, value symbol)
{
CAMLparam2 (filename, symbol);
- CAMLlocal2 (res, v);
+ CAMLlocal3 (res, v, handle_v);
void *handle;
char *p;
v = caml_copy_string(caml_dlerror());
Store_field(res, 0, v);
} else {
+ handle_v = Val_handle(handle);
res = caml_alloc(1,0);
- v = caml_natdynlink_run(handle, symbol);
+ v = caml_natdynlink_run(handle_v, symbol);
Store_field(res, 0, v);
}
CAMLreturn(res);
#include "caml/signals_machdep.h"
#include "signals_osdep.h"
#include "caml/stack.h"
-#include "spacetime.h"
+#include "caml/spacetime.h"
#ifdef HAS_STACK_OVERFLOW_DETECTION
#include <sys/time.h>
#include "caml/minor_gc.h"
#include "caml/misc.h"
#include "caml/mlvalues.h"
+#include "caml/osdeps.h"
#include "caml/roots.h"
#include "caml/signals.h"
#include "caml/stack.h"
#include "caml/sys.h"
-#include "spacetime.h"
+#include "caml/spacetime.h"
#ifdef WITH_SPACETIME
caml_spacetime_static_shape_tables = &caml_spacetime_shapes;
- ap_interval = getenv ("OCAML_SPACETIME_INTERVAL");
+ ap_interval = caml_secure_getenv ("OCAML_SPACETIME_INTERVAL");
if (ap_interval != NULL) {
unsigned int interval = 0;
sscanf(ap_interval, "%u", &interval);
int dir_ok = 1;
user_specified_automatic_snapshot_dir =
- getenv("OCAML_SPACETIME_SNAPSHOT_DIR");
+ caml_secure_getenv("OCAML_SPACETIME_SNAPSHOT_DIR");
if (user_specified_automatic_snapshot_dir == NULL) {
#ifdef HAS_GETCWD
+++ /dev/null
-/**************************************************************************/
-/* */
-/* 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
#include "caml/signals.h"
#include "caml/stack.h"
#include "caml/sys.h"
-#include "spacetime.h"
+#include "caml/spacetime.h"
#include "../config/s.h"
#include "caml/signals.h"
#include "caml/stack.h"
#include "caml/sys.h"
-#include "spacetime.h"
+#include "caml/spacetime.h"
#ifdef WITH_SPACETIME
#include "caml/startup_aux.h"
#include "caml/sys.h"
#ifdef WITH_SPACETIME
-#include "spacetime.h"
+#include "caml/spacetime.h"
#endif
#ifdef HAS_UI
#include "caml/ui.h"
#endif
-void caml_main(char **argv)
+value caml_startup_exn(char **argv)
{
- char * exe_name;
- static char proc_self_exe[256];
- value res;
+ char * exe_name, * proc_self_exe;
char tos;
#ifdef WITH_SPACETIME
caml_debugger_init (); /* force debugger.o stub to be linked */
exe_name = argv[0];
if (exe_name == NULL) exe_name = "";
- if (caml_executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0)
+ proc_self_exe = caml_executable_name();
+ if (proc_self_exe != NULL)
exe_name = proc_self_exe;
else
exe_name = caml_search_exe_in_path(exe_name);
caml_sys_init(exe_name, argv);
if (sigsetjmp(caml_termination_jmpbuf.buf, 0)) {
if (caml_termination_hook != NULL) caml_termination_hook(NULL);
- return;
+ return Val_unit;
}
- res = caml_start_program();
- if (Is_exception_result(res))
- caml_fatal_uncaught_exception(Extract_exception(res));
+ return caml_start_program();
}
void caml_startup(char **argv)
{
- caml_main(argv);
+ value res = caml_startup_exn(argv);
+
+ if (Is_exception_result(res)) {
+ caml_fatal_uncaught_exception(Extract_exception(res));
+ }
+}
+
+void caml_main(char **argv)
+{
+ caml_startup(argv);
}
| Pintcomp cmp -> Kintcomp cmp
| Pmakeblock(tag, _mut, _) -> Kmakeblock(List.length args, tag)
| Pfield n -> Kgetfield n
+ | Pfield_computed -> Kgetvectitem
| Psetfield(n, _ptr, _init) -> Ksetfield n
+ | Psetfield_computed(_ptr, _init) -> Ksetvectitem
| Pfloatfield n -> Kgetfloatfield n
| Psetfloatfield (n, _init) -> Ksetfloatfield n
| Pduprecord _ -> Kccall("caml_obj_dup", 1)
let copy_compunit ic oc compunit =
seek_in ic compunit.cu_pos;
compunit.cu_pos <- pos_out oc;
- compunit.cu_force_link <- !Clflags.link_everything;
+ compunit.cu_force_link <- compunit.cu_force_link || !Clflags.link_everything;
copy_file_chunk ic oc compunit.cu_codesize;
if compunit.cu_debug > 0 then begin
seek_in ic compunit.cu_debug;
\n caml_sections, sizeof(caml_sections),\
\n argv);\
\n}\
+\nvalue caml_startup_exn(char ** argv)\
+\n{\
+\n return caml_startup_code_exn(caml_code, sizeof(caml_code),\
+\n caml_data, sizeof(caml_data),\
+\n caml_sections, sizeof(caml_sections),\
+\n argv);\
+\n}\
\n#ifdef __cplusplus\
\n}\
\n#endif\n";
let name =
String.capitalize_ascii(Filename.basename(chop_extensions file)) in
let kind =
- if Filename.check_suffix file ".cmo" then begin
- let ic = open_in_bin file in
- try
- let buffer =
- really_input_string ic (String.length Config.cmo_magic_number)
- in
- if buffer <> Config.cmo_magic_number then
- raise(Error(Not_an_object_file file));
- let compunit_pos = input_binary_int ic in
- seek_in ic compunit_pos;
- let compunit = (input_value ic : compilation_unit) in
- if compunit.cu_name <> name
- then raise(Error(Illegal_renaming(name, file, compunit.cu_name)));
- close_in ic;
- PM_impl compunit
- with x ->
- close_in ic;
- raise x
- end else
- PM_intf in
+ (* PR#7479: make sure it is either a .cmi or a .cmo *)
+ if Filename.check_suffix file ".cmi" then
+ PM_intf
+ else begin
+ let ic = open_in_bin file in
+ try
+ let buffer =
+ really_input_string ic (String.length Config.cmo_magic_number)
+ in
+ if buffer <> Config.cmo_magic_number then
+ raise(Error(Not_an_object_file file));
+ let compunit_pos = input_binary_int ic in
+ seek_in ic compunit_pos;
+ let compunit = (input_value ic : compilation_unit) in
+ if compunit.cu_name <> name
+ then raise(Error(Illegal_renaming(name, file, compunit.cu_name)));
+ close_in ic;
+ PM_impl compunit
+ with x ->
+ close_in ic;
+ raise x
+ end in
{ pm_file = file; pm_name = name; pm_kind = kind }
)
...
object code for last library member
library descriptor *)
+
+(* Tables for numbering objects *)
+
+type 'a numtable =
+ { num_cnt: int; (* The next number *)
+ num_tbl: ('a, int) Tbl.t } (* The table of already numbered objects *)
cu_primitives = List.map Primitive.byte_name
!Translmod.primitive_declarations;
cu_required_globals = Ident.Set.elements required_globals;
- cu_force_link = false;
+ cu_force_link = !Clflags.link_everything;
cu_debug = pos_debug;
cu_debugsize = size_debug } in
init(); (* Free out_buffer and reloc_info *)
| Pointer
type initialization_or_assignment =
- | Initialization
| Assignment
+ | Heap_initialization
+ | Root_initialization
type is_safe =
| Safe
(* Operations on heap blocks *)
| Pmakeblock of int * mutable_flag * block_shape
| Pfield of int
+ | Pfield_computed
| Psetfield of int * immediate_or_pointer * initialization_or_assignment
+ | Psetfield_computed of immediate_or_pointer * initialization_or_assignment
| Pfloatfield of int
| Psetfloatfield of int * initialization_or_assignment
| Pduprecord of Types.record_representation * int
inline : inline_attribute;
specialise : specialise_attribute;
is_a_functor: bool;
+ stub: bool;
}
type lambda =
inline = Default_inline;
specialise = Default_specialise;
is_a_functor = false;
+ stub = false;
}
+let default_stub_attribute =
+ { default_function_attribute with stub = true }
+
(* Build sharing keys *)
(*
Those keys are later compared with Pervasives.compare.
| Pointer
type initialization_or_assignment =
- (* CR-someday mshinwell: For multicore, perhaps it might be necessary to
- split [Initialization] into two cases, depending on whether the place
- being initialized is in the heap or not. *)
- | Initialization
| Assignment
+ (* Initialization of in heap values, like [caml_initialize] C primitive. The
+ field should not have been read before and initialization should happen
+ only once. *)
+ | Heap_initialization
+ (* Initialization of roots only. Compiles to a simple store.
+ No checks are done to preserve GC invariants. *)
+ | Root_initialization
type is_safe =
| Safe
(* Operations on heap blocks *)
| Pmakeblock of int * mutable_flag * block_shape
| Pfield of int
+ | Pfield_computed
| Psetfield of int * immediate_or_pointer * initialization_or_assignment
+ | Psetfield_computed of immediate_or_pointer * initialization_or_assignment
| Pfloatfield of int
| Psetfloatfield of int * initialization_or_assignment
| Pduprecord of Types.record_representation * int
inline : inline_attribute;
specialise : specialise_attribute;
is_a_functor: bool;
+ stub: bool;
}
type lambda =
val negate_comparison : comparison -> comparison
val default_function_attribute : function_attribute
+val default_stub_attribute : function_attribute
(***********************)
(* For static failures *)
(* However, as shown by PR#6359 such sharing may hinders the
lambda-code invariant that all bound idents are unique,
- when switchs are compiled to test sequences.
+ when switches are compiled to test sequences.
The definitive fix is the systematic introduction of exit/catch
in case action sharing is present.
*)
with
| Exit -> false
-(* Nothing is kown about exception/extension patterns,
+(* Nothing is known about exception/extension patterns,
because of potential rebind *)
let rec exc_inside p = match p.pat_desc with
| Tpat_construct (_,{cstr_tag=Cstr_extension _},_) -> true
(*
Simplify fonction normalize the first column of the match
- - records are expanded so that they posses all fields
+ - records are expanded so that they possess all fields
- aliases are removed and replaced by bindings in actions.
However or-patterns are simplified differently,
- aliases are not removed
- - or patterns (_|p) are changed into _
+ - or-patterns (_|p) are changed into _
*)
exception Var of pattern
-(* Once matchings are simplified one easily finds
+(* Once matchings are simplified one can easily find
their nature *)
let rec what_is_cases cases = match cases with
-(* A few operation on default environments *)
+(* A few operations on default environments *)
let as_matrix cases = get_mins le_pats (List.map (fun (ps,_) -> ps) cases)
-(* For extension matching, record no imformation in matrix *)
+(* For extension matching, record no information in matrix *)
let as_matrix_omega cases =
get_mins le_pats
(List.map
ors,(p::ps,act)::no
else (* p # q, go on with append/insert *)
attempt (cl::seen) rem
- end else (* q is not a or-pat, go on with append/insert *)
+ end else (* q is not an or-pat, go on with append/insert *)
attempt (cl::seen) rem
| _ -> (* [] in fact *)
(p::ps,act)::ors,no in (* success in appending *)
Splitting is first directed by or-patterns, then by
tests (e.g. constructors)/variable transitions.
- The approach is greedy, every split function attempt to
+ The approach is greedy, every split function attempts to
raise rows as much as possible in the top matrix,
then splitting applies again to the remaining rows.
do_split [] [] [] cls
-(* Ultra-naive spliting, close to semantics, used for extension,
+(* Ultra-naive splitting, close to semantics, used for extension,
as potential rebind prevents any kind of optimisation *)
and split_naive cls args def k =
end
| [ps,_ as cl]
when List.for_all group_var ps && yes <> [] ->
- (* This enables an extra division in some frequent case :
+ (* This enables an extra division in some frequent cases :
last row is made of variables only *)
split_noex yes (cl::no) []
| (p::_,_) as cl::rem ->
There is one set of functions per matching style
(constants, constructors etc.)
- - matcher function are arguments to make_default (for defaukt handlers)
+ - matcher functions are arguments to make_default (for default handlers)
They may raise NoMatch or OrPat and perform the full
matching (selection + arguments).
- get_args and get_key are for the compiled matrices, note that
- selection and geting arguments are separed.
+ selection and getting arguments are separated.
- - make_ _matching combines the previous functions for produicing
+ - make_ _matching combines the previous functions for producing
new ``pattern_matching'' records.
*)
| _ -> get_arg_lazy p rem
(* Inlining the tag tests before calling the primitive that works on
- lazy blocks. This is alse used in translcore.ml.
- No call other than Obj.tag when the value has been forced before.
+ lazy blocks. This is also used in translcore.ml.
+ No other call than Obj.tag when the value has been forced before.
*)
let prim_obj_tag =
let hs,handle_shared = handle_shared () in
let acts = Array.map handle_shared acts in
-(* Recontruct default and switch list *)
+(* Reconstruct default and switch list *)
let d = match d with
| None -> None
| Some d -> Some (acts.(d)) in
let inters = match l with
| (i,act)::rem ->
let act_index =
- (* In case there is some hole and that a switch is emited,
+ (* In case there is some hole and that a switch is emitted,
action 0 will be used as the action of unreacheable
cases (cf. switch.ml, make_switch).
Hence, this action will be shared *)
pretty_jumps jmps
end ;
None,fail,jmps
- end else begin (* Two many non-matched constructors -> reduced information *)
+ end else begin (* Too many non-matched constructors -> reduced information *)
if dbg then eprintf "POS->NEG!!!\n%!" ;
let fail,jumps = mk_failaction_neg partial ctx defs in
if dbg then
const_lambda_list in
call_switcher fail arg 0 255 int_lambda_list
| Const_string _ ->
-(* Note as the bytecode compiler may resort to dichotmic search,
- the clauses of strinswitch are sorted with duplicate removed.
+(* Note as the bytecode compiler may resort to dichotomic search,
+ the clauses of stringswitch are sorted with duplicates removed.
This partly applies to the native code compiler, which requires
no duplicates *)
let const_lambda_list = sort_lambda_list const_lambda_list in
This exception is raised when the compiler cannot produce code
because control cannot reach the compiled clause,
- Unused is raised initialy in compile_test.
+ Unused is raised initially in compile_test.
compile_list (for compiling switch results) catch Unused
- comp_match_handlers (for compililing splitted matches)
+ comp_match_handlers (for compiling splitted matches)
may reraise Unused
| rem ->
let rec c_rec body total_body = function
| [] -> body, total_body
- (* Hum, -1 meant never taken
+ (* Hum, -1 means never taken
| (-1,pm)::rem -> c_rec body total_body rem *)
| (i,pm)::rem ->
let ctx_i,total_rem = jumps_extract i total_body in
Notice that exhaustiveness information is trusted by the compiler,
that is, a match flagged as Total should not fail at runtime.
- More specifically, for instance if match y with x::_ -> x uis flagged
+ More specifically, for instance if match y with x::_ -> x is flagged
total (as it happens during JoCaml compilation) then y cannot be []
at runtime. As a consequence, the static Total exhaustiveness information
- have to to be downgraded to Partial, in the dubious cases where guards
+ have to be downgraded to Partial, in the dubious cases where guards
or lazy pattern execute arbitrary code that may perform side effects
and change the subject values.
LM:
didn't optimize situations where the rhs tuples are hidden under
a more complex context.
- The idea comes from Alain Frisch which suggested and implemented
+ The idea comes from Alain Frisch who suggested and implemented
the following compilation method, based on Lassign:
let x = dummy in let y = dummy in
| Pmakeblock(tag, Mutable, shape) ->
fprintf ppf "makemutable %i%a" tag block_shape shape
| Pfield n -> fprintf ppf "field %i" n
+ | Pfield_computed -> fprintf ppf "field_computed"
| Psetfield(n, ptr, init) ->
let instr =
match ptr with
in
let init =
match init with
- | Initialization -> "(init)"
+ | Heap_initialization -> "(heap-init)"
+ | Root_initialization -> "(root-init)"
| Assignment -> ""
in
fprintf ppf "setfield_%s%s %i" instr init n
+ | Psetfield_computed (ptr, init) ->
+ let instr =
+ match ptr with
+ | Pointer -> "ptr"
+ | Immediate -> "imm"
+ in
+ let init =
+ match init with
+ | Heap_initialization -> "(heap-init)"
+ | Root_initialization -> "(root-init)"
+ | Assignment -> ""
+ in
+ fprintf ppf "setfield_%s%s_computed" instr init
| Pfloatfield n -> fprintf ppf "floatfield %i" n
| Psetfloatfield (n, init) ->
let init =
match init with
- | Initialization -> "(init)"
+ | Heap_initialization -> "(heap-init)"
+ | Root_initialization -> "(root-init)"
| Assignment -> ""
in
fprintf ppf "setfloatfield%s %i" init n
| Psetglobal _ -> "Psetglobal"
| Pmakeblock _ -> "Pmakeblock"
| Pfield _ -> "Pfield"
+ | Pfield_computed -> "Pfield_computed"
| Psetfield _ -> "Psetfield"
+ | Psetfield_computed _ -> "Psetfield_computed"
| Pfloatfield _ -> "Pfloatfield"
| Psetfloatfield _ -> "Psetfloatfield"
| Pduprecord _ -> "Pduprecord"
| Pint_as_pointer -> "Pint_as_pointer"
| Popaque -> "Popaque"
-let function_attribute ppf { inline; specialise; is_a_functor } =
+let function_attribute ppf { inline; specialise; is_a_functor; stub } =
if is_a_functor then
fprintf ppf "is_a_functor@ ";
+ if stub then
+ fprintf ppf "stub@ ";
begin match inline with
| Default_inline -> ()
| Always_inline -> fprintf ppf "always_inline@ "
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Pierre Chambart, OCamlPro *)
+(* Mark Shinwell and Leo White, Jane Street Europe *)
+(* *)
+(* Copyright 2013--2016 OCamlPro SAS *)
+(* Copyright 2014--2016 Jane Street Group LLC *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+type effects = No_effects | Only_generative_effects | Arbitrary_effects
+type coeffects = No_coeffects | Has_coeffects
+
+let for_primitive (prim : Lambda.primitive) =
+ match prim with
+ | Pignore | Pidentity | Pbytes_to_string | Pbytes_of_string ->
+ No_effects, No_coeffects
+ | Pmakeblock _
+ | Pmakearray (_, Mutable) -> Only_generative_effects, No_coeffects
+ | Pmakearray (_, Immutable) -> No_effects, No_coeffects
+ | Pduparray (_, Immutable) ->
+ No_effects, No_coeffects (* Pduparray (_, Immutable) is allowed only on
+ immutable arrays. *)
+ | Pduparray (_, Mutable) | Pduprecord _ ->
+ Only_generative_effects, Has_coeffects
+ | Pccall { prim_name =
+ ( "caml_format_float" | "caml_format_int" | "caml_int32_format"
+ | "caml_nativeint_format" | "caml_int64_format" ) } ->
+ No_effects, No_coeffects
+ | Plazyforce
+ | Pccall _ -> Arbitrary_effects, Has_coeffects
+ | Praise _ -> Arbitrary_effects, No_coeffects
+ | Pnot
+ | Pnegint
+ | Paddint
+ | Psubint
+ | Pmulint
+ | Pandint
+ | Porint
+ | Pxorint
+ | Plslint
+ | Plsrint
+ | Pasrint
+ | Pintcomp _ -> No_effects, No_coeffects
+ | Pdivbint { is_safe = Unsafe }
+ | Pmodbint { is_safe = Unsafe }
+ | Pdivint Unsafe
+ | Pmodint Unsafe ->
+ No_effects, No_coeffects (* Will not raise [Division_by_zero]. *)
+ | Pdivbint { is_safe = Safe }
+ | Pmodbint { is_safe = Safe }
+ | Pdivint Safe
+ | Pmodint Safe ->
+ Arbitrary_effects, No_coeffects
+ | Poffsetint _ -> No_effects, No_coeffects
+ | Poffsetref _ -> Arbitrary_effects, Has_coeffects
+ | Pintoffloat
+ | Pfloatofint
+ | Pnegfloat
+ | Pabsfloat
+ | Paddfloat
+ | Psubfloat
+ | Pmulfloat
+ | Pdivfloat
+ | Pfloatcomp _ -> No_effects, No_coeffects
+ | Pstringlength | Pbyteslength
+ | Parraylength _ ->
+ No_effects, Has_coeffects (* That old chestnut: [Obj.truncate]. *)
+ | Pisint
+ | Pisout
+ | Pbittest
+ | Pbintofint _
+ | Pintofbint _
+ | Pcvtbint _
+ | Pnegbint _
+ | Paddbint _
+ | Psubbint _
+ | Pmulbint _
+ | Pandbint _
+ | Porbint _
+ | Pxorbint _
+ | Plslbint _
+ | Plsrbint _
+ | Pasrbint _
+ | Pbintcomp _ -> No_effects, No_coeffects
+ | Pbigarraydim _ ->
+ No_effects, Has_coeffects (* Some people resize bigarrays in place. *)
+ | Pfield _
+ | Pfield_computed
+ | Pfloatfield _
+ | Pgetglobal _
+ | Parrayrefu _
+ | Pstringrefu
+ | Pbytesrefu
+ | Pstring_load_16 true
+ | Pstring_load_32 true
+ | Pstring_load_64 true
+ | Pbigarrayref (true, _, _, _)
+ | Pbigstring_load_16 true
+ | Pbigstring_load_32 true
+ | Pbigstring_load_64 true ->
+ No_effects, Has_coeffects
+ | Parrayrefs _
+ | Pstringrefs
+ | Pbytesrefs
+ | Pstring_load_16 false
+ | Pstring_load_32 false
+ | Pstring_load_64 false
+ | Pbigarrayref (false, _, _, _)
+ | Pbigstring_load_16 false
+ | Pbigstring_load_32 false
+ | Pbigstring_load_64 false ->
+ (* May trigger a bounds check exception. *)
+ Arbitrary_effects, Has_coeffects
+ | Psetfield _
+ | Psetfield_computed _
+ | Psetfloatfield _
+ | Psetglobal _
+ | Parraysetu _
+ | Parraysets _
+ | Pbytessetu
+ | Pbytessets
+ | Pstring_set_16 _
+ | Pstring_set_32 _
+ | Pstring_set_64 _
+ | Pbigarrayset _
+ | Pbigstring_set_16 _
+ | Pbigstring_set_32 _
+ | Pbigstring_set_64 _ ->
+ (* Whether or not some of these are "unsafe" is irrelevant; they always
+ have an effect. *)
+ Arbitrary_effects, No_coeffects
+ | Pctconst _ -> No_effects, No_coeffects
+ | Pbswap16
+ | Pbbswap _ -> No_effects, No_coeffects
+ | Pint_as_pointer -> No_effects, No_coeffects
+ | Popaque -> Arbitrary_effects, Has_coeffects
+ | Ploc _ ->
+ (* Removed by [Translcore]. *)
+ No_effects, No_coeffects
+ | Prevapply
+ | Pdirapply ->
+ (* Removed by [Simplif], but there is no reason to prevent using
+ the current analysis function before/during Simplif. *)
+ Arbitrary_effects, Has_coeffects
+ | Psequand
+ | Psequor ->
+ (* Removed by [Closure_conversion] in the flambda pipeline. *)
+ No_effects, No_coeffects
+
+type return_type =
+ | Float
+ | Other
+
+let return_type_of_primitive (prim:Lambda.primitive) =
+ match prim with
+ | Pfloatofint
+ | Pnegfloat
+ | Pabsfloat
+ | Paddfloat
+ | Psubfloat
+ | Pmulfloat
+ | Pdivfloat
+ | Pfloatfield _
+ | Parrayrefu Pfloatarray
+ | Parrayrefs Pfloatarray ->
+ Float
+ | _ ->
+ Other
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Pierre Chambart, OCamlPro *)
+(* Mark Shinwell and Leo White, Jane Street Europe *)
+(* *)
+(* Copyright 2013--2016 OCamlPro SAS *)
+(* Copyright 2014--2016 Jane Street Group LLC *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+(** Description of the semantics of primitives, to be used for optimization
+ purposes.
+
+ "No effects" means that the primitive does not change the observable state
+ of the world. For example, it must not write to any mutable storage,
+ call arbitrary external functions or change control flow (e.g. by raising
+ an exception). Note that allocation is not "No effects" (see below).
+
+ It is assumed in the compiler that applications of primitives with no
+ effects, whose results are not used, may be eliminated. It is further
+ assumed that applications of primitives with no effects may be
+ duplicated (and thus possibly executed more than once).
+
+ (Exceptions arising from allocation points, for example "out of memory" or
+ exceptions propagated from finalizers or signal handlers, are treated as
+ "effects out of the ether" and thus ignored for our determination here
+ of effectfulness. The same goes for floating point operations that may
+ cause hardware traps on some platforms.)
+
+ "Only generative effects" means that a primitive does not change the
+ observable state of the world save for possibly affecting the state of
+ the garbage collector by performing an allocation. Applications of
+ primitives that only have generative effects and whose results are unused
+ may be eliminated by the compiler. However, unlike "No effects"
+ primitives, such applications will never be eligible for duplication.
+
+ "Arbitrary effects" covers all other primitives.
+
+ "No coeffects" means that the primitive does not observe the effects (in
+ the sense described above) of other expressions. For example, it must not
+ read from any mutable storage or call arbitrary external functions.
+
+ It is assumed in the compiler that, subject to data dependencies,
+ expressions with neither effects nor coeffects may be reordered with
+ respect to other expressions.
+*)
+
+type effects = No_effects | Only_generative_effects | Arbitrary_effects
+type coeffects = No_coeffects | Has_coeffects
+
+(** Describe the semantics of a primitive. This does not take into account of
+ the (non-)(co)effectfulness of the arguments in a primitive application.
+ To determine whether such an application is (co)effectful, the arguments
+ must also be analysed. *)
+val for_primitive: Lambda.primitive -> effects * coeffects
+
+type return_type =
+ | Float
+ | Other
+
+val return_type_of_primitive: Lambda.primitive -> return_type
'Some' constructor, only to deconstruct it immediately in the
function's body. *)
-let split_default_wrapper ?(create_wrapper_body = fun lam -> lam)
- ~id:fun_id ~kind ~params ~body ~attr ~wrapper_attr ~loc () =
+let split_default_wrapper ~id:fun_id ~kind ~params ~body ~attr ~loc =
let rec aux map = function
| Llet(Strict, k, id, (Lifthenelse(Lvar optparam, _, _) as def), rest) when
Ident.name optparam = "*opt*" && List.mem optparam params
(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 = wrapper_attr; loc}); inner]
+ let body, inner = aux [] body in
+ let attr = default_stub_attribute in
+ [(fun_id, Lfunction{kind; params; body; attr; loc}); inner]
with Exit ->
[(fun_id, Lfunction{kind; params; body; attr; loc})]
val simplify_lambda: string -> lambda -> lambda
val split_default_wrapper
- : ?create_wrapper_body:(lambda -> lambda)
- -> id:Ident.t
+ : 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 *)
exception Error of error
-(* Tables for numbering objects *)
-
-type 'a numtable =
- { num_cnt: int; (* The next number *)
- num_tbl: ('a, int) Tbl.t } (* The table of already numbered objects *)
-
let empty_numtable = { num_cnt = 0; num_tbl = Tbl.empty }
let find_numtable nt key =
val output_primitive_table: out_channel -> unit
val data_global_map: unit -> Obj.t
val data_primitive_names: unit -> string
+val transl_const: Lambda.structured_constant -> Obj.t
(* Functions for the toplevel *)
let add_inline_attribute expr loc attributes =
match expr, get_inline_attribute attributes with
| expr, Default_inline -> expr
- | Lfunction({ attr } as funct), inline_attribute ->
+ | Lfunction({ attr = { stub = false } as attr } as funct), inline ->
begin match attr.inline with
| Default_inline -> ()
| Always_inline | Never_inline | Unroll _ ->
Location.prerr_warning loc
(Warnings.Duplicated_attribute "inline")
end;
- let attr = { attr with inline = inline_attribute } in
+ let attr = { attr with inline } in
Lfunction { funct with attr = attr }
| expr, (Always_inline | Never_inline | Unroll _) ->
Location.prerr_warning loc
let add_specialise_attribute expr loc attributes =
match expr, get_specialise_attribute attributes with
| expr, Default_specialise -> expr
- | Lfunction({ attr } as funct), specialise_attribute ->
+ | Lfunction({ attr = { stub = false } as attr } as funct), specialise ->
begin match attr.specialise with
| Default_specialise -> ()
| Always_specialise | Never_specialise ->
Location.prerr_warning loc
(Warnings.Duplicated_attribute "specialise")
end;
- let attr = { attr with specialise = specialise_attribute } in
+ let attr = { attr with specialise } in
Lfunction { funct with attr }
| expr, (Always_specialise | Never_specialise) ->
Location.prerr_warning loc
(0, List.map (fun lab -> Const_immstring lab) lst))
let set_inst_var obj id expr =
- let kind =
- match Typeopt.maybe_pointer expr with
- | Pointer -> Paddrarray
- | Immediate -> Pintarray
- in
- Lprim(Parraysetu kind, [Lvar obj; Lvar id; transl_exp expr], Location.none)
+ Lprim(Psetfield_computed (Typeopt.maybe_pointer expr, Assignment),
+ [Lvar obj; Lvar id; transl_exp expr], Location.none)
let transl_val tbl create name =
mkappl (oo_prim (if create then "new_variable" else "get_variable"),
[lfunction (self :: args)
(if not (IdentSet.mem env (free_variables body')) then body' else
Llet(Alias, Pgenval, env,
- Lprim(Parrayrefu Paddrarray,
+ Lprim(Pfield_computed,
[Lvar self; Lvar env2],
Location.none),
body'))]
let env1 = Ident.create "env" and env1' = Ident.create "env'" in
let copy_env self =
if top then lambda_unit else
- Lifused(env2, Lprim(Parraysetu Paddrarray,
+ Lifused(env2, Lprim(Psetfield_computed (Pointer, Assignment),
[Lvar self; Lvar env2; Lvar env1'],
Location.none))
and subst_env envs l lam =
let find_primitive prim_name =
Hashtbl.find primitives_table prim_name
+let prim_restore_raw_backtrace =
+ Primitive.simple ~name:"caml_restore_raw_backtrace" ~arity:2 ~alloc:false
+
let specialize_comparison table env ty =
let (gencomp, intcomp, floatcomp, stringcomp, bytescomp,
nativeintcomp, int32comp, int64comp, _) = table in
Lfunction{kind = Curried; params = [parm];
body = Matching.inline_lazy_force (Lvar parm) Location.none;
loc = loc;
- attr = default_function_attribute }
+ attr = default_stub_attribute }
| Ploc kind ->
let lam = lam_of_loc kind loc in
begin match p.prim_arity with
| 1 -> (* TODO: we should issue a warning ? *)
let param = Ident.create "prim" in
Lfunction{kind = Curried; params = [param];
- attr = default_function_attribute;
+ attr = default_stub_attribute;
loc = loc;
body = Lprim(Pmakeblock(0, Immutable, None),
[lam; Lvar param], loc)}
if n <= 0 then [] else Ident.create "prim" :: make_params (n-1) in
let params = make_params p.prim_arity in
Lfunction{ kind = Curried; params;
- attr = default_function_attribute;
+ attr = default_stub_attribute;
loc = loc;
body = Lprim(prim, List.map (fun id -> Lvar id) params, loc) }
Const_base(Const_float f) -> f
| _ -> fatal_error "Translcore.extract_float"
-(* To find reasonable names for let-bound and lambda-bound idents *)
-
-let rec name_pattern default = function
- [] -> Ident.create default
- | {c_lhs=p; _} :: rem ->
- match p.pat_desc with
- Tpat_var (id, _) -> id
- | Tpat_alias(_, id, _) -> id
- | _ -> name_pattern default rem
-
(* Push the default values under the functional abstractions *)
(* Also push bindings of module patterns, since this sound *)
let rec push_defaults loc bindings cases partial =
match cases with
[{c_lhs=pat; c_guard=None;
- c_rhs={exp_desc = Texp_function(l, pl,partial)} as exp}] ->
- let pl = push_defaults exp.exp_loc bindings pl partial in
+ c_rhs={exp_desc = Texp_function { arg_label; param; cases; partial; } }
+ as exp}] ->
+ let cases = push_defaults exp.exp_loc bindings cases partial in
[{c_lhs=pat; c_guard=None;
- c_rhs={exp with exp_desc = Texp_function(l, pl, partial)}}]
+ c_rhs={exp with exp_desc = Texp_function { arg_label; param; cases;
+ partial; }}}]
| [{c_lhs=pat; c_guard=None;
c_rhs={exp_attributes=[{txt="#default"},_];
exp_desc = Texp_let
in
[{case with c_rhs=exp}]
| {c_lhs=pat; c_rhs=exp; c_guard=_} :: _ when bindings <> [] ->
- let param = name_pattern "param" cases in
+ let param = Typecore.name_pattern "param" cases in
let name = Ident.name param in
let exp =
{ exp with exp_loc = loc; exp_desc =
let kind = if public_send then Public else Self in
let obj = Ident.create "obj" and meth = Ident.create "meth" in
Lfunction{kind = Curried; params = [obj; meth];
- attr = default_function_attribute;
+ attr = default_stub_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;
+ attr = default_stub_attribute;
loc = e.exp_loc;
body = Lsend(Cached, Lvar meth, Lvar obj,
[Lvar cache; Lvar pos], e.exp_loc)}
Lconst(Const_base cst)
| Texp_let(rec_flag, pat_expr_list, body) ->
transl_let rec_flag pat_expr_list (event_before body (transl_exp body))
- | Texp_function (_, pat_expr_list, partial) ->
+ | Texp_function { arg_label = _; param; cases; partial; } ->
let ((kind, params), body) =
event_function e
(function repr ->
- let pl = push_defaults e.exp_loc [] pat_expr_list partial in
- transl_function e.exp_loc !Clflags.native_code repr partial pl)
+ let pl = push_defaults e.exp_loc [] cases partial in
+ transl_function e.exp_loc !Clflags.native_code repr partial
+ param pl)
in
let attr = {
default_function_attribute with
match argl with [obj; meth; cache; pos] ->
wrap (Lsend(Cached, meth, obj, [cache; pos], e.exp_loc))
| _ -> assert false
+ else if p.prim_name = "%raise_with_backtrace" then begin
+ let texn1 = List.hd args (* Should not fail by typing *) in
+ let texn2,bt = match argl with
+ | [a;b] -> a,b
+ | _ -> assert false (* idem *)
+ in
+ let vexn = Ident.create "exn" in
+ Llet(Strict, Pgenval, vexn, texn2,
+ event_before e begin
+ Lsequence(
+ wrap (Lprim (Pccall prim_restore_raw_backtrace,
+ [Lvar vexn;bt],
+ e.exp_loc)),
+ wrap0 (Lprim(Praise Raise_reraise,
+ [event_after texn1 (Lvar vexn)],
+ e.exp_loc))
+ )
+ end
+ )
+ end
else begin
let prim = transl_primitive_application
e.exp_loc p e.exp_env prim_type (Some path) args in
| Texp_match(arg, pat_expr_list, exn_pat_expr_list, partial) ->
transl_match e arg pat_expr_list exn_pat_expr_list partial
| Texp_try(body, pat_expr_list) ->
- let id = name_pattern "exn" pat_expr_list in
+ let id = Typecore.name_pattern "exn" pat_expr_list in
Ltrywith(transl_exp body, id,
Matching.for_trywith (Lvar id) (transl_cases_try pat_expr_list))
| Texp_tuple el ->
ap_inlined=Default_inline;
ap_specialised=Default_specialise}
| Texp_instvar(path_self, path, _) ->
- Lprim(Parrayrefu Paddrarray,
+ Lprim(Pfield_computed,
[transl_normal_path path_self; transl_normal_path path], e.exp_loc)
| Texp_setinstvar(path_self, path, _, expr) ->
transl_setinstvar e.exp_loc (transl_normal_path path_self) path expr
| Texp_constant
( Const_int _ | Const_char _ | Const_string _
| Const_int32 _ | Const_int64 _ | Const_nativeint _ )
- | Texp_function(_, _, _)
+ | Texp_function _
| Texp_construct (_, {cstr_arity = 0}, _)
-> transl_exp e
| Texp_constant(Const_float _) ->
loc}
| lam ->
Lfunction{kind = Curried; params = [id_arg]; body = lam;
- attr = default_function_attribute; loc = loc}
+ attr = default_stub_attribute; loc = loc}
in
List.fold_left
(fun body (id, lam) -> Llet(Strict, Pgenval, id, lam, body))
sargs)
: Lambda.lambda)
-and transl_function loc untuplify_fn repr partial cases =
+and transl_function loc untuplify_fn repr partial param cases =
match cases with
[{c_lhs=pat; c_guard=None;
- c_rhs={exp_desc = Texp_function(_, pl,partial')} as exp}]
+ c_rhs={exp_desc = Texp_function { arg_label = _; param = param'; cases;
+ partial = partial'; }} as exp}]
when Parmatch.fluid pat ->
- let param = name_pattern "param" cases in
let ((_, params), body) =
- transl_function exp.exp_loc false repr partial' pl in
+ transl_function exp.exp_loc false repr partial' param' cases in
((Curried, param :: params),
Matching.for_function loc None (Lvar param) [pat, body] partial)
| {c_lhs={pat_desc = Tpat_tuple pl}} :: _ when untuplify_fn ->
Matching.for_tupled_function loc params
(transl_tupled_cases pats_expr_list) partial)
with Matching.Cannot_flatten ->
- let param = name_pattern "param" cases in
((Curried, [param]),
Matching.for_function loc repr (Lvar param)
(transl_cases cases) partial)
end
| _ ->
- let param = name_pattern "param" cases in
((Curried, [param]),
Matching.for_function loc repr (Lvar param)
(transl_cases cases) partial)
Lletrec(List.map2 transl_case pat_expr_list idlist, body)
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], loc)
+ Lprim(Psetfield_computed (maybe_pointer expr, Assignment),
+ [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
end
and transl_match e arg pat_expr_list exn_pat_expr_list partial =
- let id = name_pattern "exn" exn_pat_expr_list
+ let id = Typecore.name_pattern "exn" exn_pat_expr_list
and cases = transl_cases pat_expr_list
and exn_cases = transl_cases_try exn_pat_expr_list in
let static_catch body val_ids handler =
| {exp_desc = Texp_tuple argl}, [] ->
Matching.for_multiple_match e.exp_loc (transl_list argl) cases partial
| {exp_desc = Texp_tuple argl}, _ :: _ ->
- let val_ids = List.map (fun _ -> name_pattern "val" []) argl in
+ let val_ids = List.map (fun _ -> Typecore.name_pattern "val" []) argl in
let lvars = List.map (fun id -> Lvar id) val_ids in
static_catch (transl_list argl) val_ids
(Matching.for_multiple_match e.exp_loc lvars cases partial)
| arg, [] ->
Matching.for_function e.exp_loc None (transl_exp arg) cases partial
| arg, _ :: _ ->
- let val_id = name_pattern "val" pat_expr_list in
+ let val_id = Typecore.name_pattern "val" pat_expr_list in
static_catch [transl_exp arg] [val_id]
(Matching.for_function e.exp_loc None (Lvar val_id) cases partial)
Lfunction{kind = Curried; params = [param];
attr = { inline = inline_attribute;
specialise = Default_specialise;
- is_a_functor = true };
+ is_a_functor = true;
+ stub = false; };
loc = loc;
body = transl_module Tcoerce_none bodypath body}
| Tcoerce_functor(ccarg, ccres) ->
Lfunction{kind = Curried; params = [param'];
attr = { inline = inline_attribute;
specialise = Default_specialise;
- is_a_functor = true };
+ is_a_functor = true;
+ stub = false; };
loc = loc;
body = Llet(Alias, Pgenval, param,
apply_coercion loc Alias ccarg
| Tstr_open _ -> more_idents rem
| Tstr_class _ -> more_idents rem
| Tstr_class_type _ -> more_idents rem
+ | Tstr_include{incl_mod={mod_desc =
+ Tmod_constraint ({mod_desc = Tmod_structure str},
+ _, _, _)}} ->
+ all_idents str.str_items @ more_idents rem
| Tstr_include _ -> more_idents rem
| Tstr_module {mb_expr={mod_desc = Tmod_structure str}}
| Tstr_module{mb_expr={mod_desc =
| Tstr_class cl_list ->
List.map (fun (ci, _) -> ci.ci_id_class) cl_list @ all_idents rem
| Tstr_class_type _ -> all_idents rem
+
+ | Tstr_include{incl_type; incl_mod={mod_desc =
+ Tmod_constraint ({mod_desc = Tmod_structure str},
+ _, _, _)}} ->
+ bound_value_identifiers incl_type @ all_idents str.str_items @ all_idents rem
| Tstr_include incl ->
bound_value_identifiers incl.incl_type @ all_idents rem
+
| Tstr_module {mb_id;mb_expr={mod_desc = Tmod_structure str}}
| Tstr_module{mb_id;
mb_expr={mod_desc =
with Not_found ->
fatal_error("Translmod.nat_toplevel_name: " ^ Ident.unique_name id)
+let field_of_str loc str =
+ let ids = Array.of_list (defined_idents str.str_items) in
+ fun (pos, cc) ->
+ match cc with
+ | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } ->
+ transl_primitive pc_loc pc_desc pc_env pc_type None
+ | _ -> apply_coercion loc Strict cc (Lvar ids.(pos))
+
+
let transl_store_structure glob map prims str =
let rec transl_store rootpath subst = function
[] ->
in
(* Careful: see next case *)
let subst = !transl_store_subst in
- let ids = Array.of_list (defined_idents str.str_items) in
- let field (pos, cc) =
- 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 loc Strict cc (Lvar ids.(pos))
- in
+ let field = field_of_str loc str in
Lsequence(lam,
Llet(Strict, Pgenval, id,
subst_lambda subst
in
Lsequence(subst_lambda subst lam,
transl_store rootpath (add_idents false ids subst) rem)
+
+ | Tstr_include{
+ incl_loc=loc;
+ incl_mod= {
+ mod_desc = Tmod_constraint (
+ ({mod_desc = Tmod_structure str} as mexp), _, _,
+ (Tcoerce_structure (map, _)))};
+ incl_attributes;
+ incl_type;
+ } ->
+ List.iter (Translattribute.check_attribute_on_module mexp)
+ incl_attributes;
+ (* Shouldn't we use mod_attributes instead of incl_attributes?
+ Same question for the Tstr_module cases above, btw. *)
+ let lam =
+ transl_store None subst str.str_items
+ (* It is tempting to pass rootpath instead of None
+ in order to give a more precise name to exceptions
+ in the included structured, but this would introduce
+ a difference of behavior compared to bytecode. *)
+ in
+ let subst = !transl_store_subst in
+ let field = field_of_str loc str in
+ let ids0 = bound_value_identifiers incl_type in
+ let rec loop ids args =
+ match ids, args with
+ | [], [] ->
+ transl_store rootpath (add_idents true ids0 subst) rem
+ | id :: ids, arg :: args ->
+ Llet(Alias, Pgenval, id, subst_lambda subst (field arg),
+ Lsequence(store_ident loc id,
+ loop ids args))
+ | _ -> assert false
+ in
+ Lsequence(lam, loop ids0 map)
+
+
| Tstr_include incl ->
let ids = bound_value_identifiers incl.incl_type in
let modl = incl.incl_mod in
try
let (pos, cc) = Ident.find_same id map in
let init_val = apply_coercion loc Alias cc (Lvar id) in
- Lprim(Psetfield(pos, Pointer, Initialization),
+ Lprim(Psetfield(pos, Pointer, Root_initialization),
[Lprim(Pgetglobal glob, [], loc); init_val],
loc)
with Not_found ->
List.fold_right (add_ident may_coerce) idlist subst
and store_primitive (pos, prim) cont =
- Lsequence(Lprim(Psetfield(pos, Pointer, Initialization),
+ Lsequence(Lprim(Psetfield(pos, Pointer, Root_initialization),
[Lprim(Pgetglobal glob, [], Location.none);
transl_primitive Location.none
prim.pc_desc prim.pc_env prim.pc_type None],
(List.length component_names,
make_sequence
(fun pos id ->
- Lprim(Psetfield(pos, Pointer, Initialization),
+ Lprim(Psetfield(pos, Pointer, Root_initialization),
[Lprim(Pgetglobal target_name, [], Location.none);
get_component id],
Location.none))
apply_coercion Location.none Strict coercion components,
make_sequence
(fun pos _id ->
- Lprim(Psetfield(pos, Pointer, Initialization),
+ Lprim(Psetfield(pos, Pointer, Root_initialization),
[Lprim(Pgetglobal target_name, [], Location.none);
Lprim(Pfield pos, [Lvar blk], Location.none)],
Location.none))
if !method_count = 0 then (size, expr) else
(size+1,
Lsequence(
- Lprim(Psetfield(size, Pointer, Initialization),
+ Lprim(Psetfield(size, Pointer, Root_initialization),
[Lprim(Pgetglobal glob, [], Location.none);
Lprim (Pccall prim_makearray,
[int !method_count; int 0],
-alloc.o: alloc.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/custom.h caml/major_gc.h caml/freelist.h \
- caml/memory.h caml/gc.h caml/minor_gc.h caml/address_class.h \
- caml/stacks.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 \
- 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 \
- caml/freelist.h caml/minor_gc.h caml/address_class.h caml/backtrace.h \
- caml/exec.h caml/backtrace_prim.h caml/fail.h
+afl.o: afl.c caml/misc.h caml/config.h caml/../../config/m.h \
+ caml/../../config/s.h caml/mlvalues.h caml/osdeps.h
+alloc.o: alloc.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/custom.h caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \
+ caml/minor_gc.h caml/address_class.h caml/stacks.h
+array.o: array.c caml/alloc.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/spacetime.h
+backtrace.o: backtrace.c caml/alloc.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 caml/freelist.h \
+ caml/minor_gc.h caml/address_class.h caml/backtrace.h caml/exec.h \
+ caml/backtrace_prim.h caml/fail.h
backtrace_prim.o: backtrace_prim.c caml/config.h caml/../../config/m.h \
- caml/../../config/s.h caml/compatibility.h caml/mlvalues.h caml/misc.h \
- caml/alloc.h caml/custom.h caml/io.h caml/instruct.h caml/intext.h \
- caml/exec.h caml/fix_code.h caml/memory.h caml/gc.h caml/major_gc.h \
+ caml/../../config/s.h caml/mlvalues.h caml/misc.h caml/alloc.h \
+ caml/custom.h caml/io.h caml/instruct.h caml/intext.h caml/exec.h \
+ caml/fix_code.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/startup.h \
caml/stacks.h caml/sys.h caml/backtrace.h caml/fail.h \
caml/backtrace_prim.h
-callback.o: callback.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/memory.h caml/gc.h \
- caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
- caml/interp.h caml/instruct.h caml/fix_code.h caml/stacks.h
+callback.o: callback.c caml/callback.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 \
+ caml/minor_gc.h caml/address_class.h caml/interp.h caml/instruct.h \
+ caml/fix_code.h caml/stacks.h
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/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 \
+ caml/../../config/m.h caml/../../config/s.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/compact.h
+compare.o: compare.c caml/custom.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 \
caml/minor_gc.h caml/address_class.h
-custom.o: custom.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/custom.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
-debugger.o: debugger.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/debugger.h caml/fail.h caml/fix_code.h \
+custom.o: custom.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/custom.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
+debugger.o: debugger.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/debugger.h caml/osdeps.h caml/fail.h caml/fix_code.h \
caml/instruct.h caml/intext.h caml/io.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
dynlink.o: dynlink.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/dynlink.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/osdeps.h caml/prims.h caml/signals.h
-extern.o: extern.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/custom.h caml/fail.h caml/gc.h caml/intext.h \
- caml/io.h caml/md5.h caml/memory.h caml/major_gc.h caml/freelist.h \
- caml/minor_gc.h caml/address_class.h caml/reverse.h
-fail.o: fail.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/io.h caml/gc.h caml/memory.h \
+ caml/../../config/s.h caml/alloc.h caml/misc.h caml/mlvalues.h \
+ caml/dynlink.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/osdeps.h \
+ caml/prims.h caml/signals.h
+extern.o: extern.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/custom.h caml/fail.h caml/gc.h caml/intext.h caml/io.h caml/md5.h \
+ caml/memory.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
+ caml/address_class.h caml/reverse.h
+fail.o: fail.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/fail.h caml/io.h caml/gc.h caml/memory.h caml/major_gc.h \
+ caml/freelist.h caml/minor_gc.h caml/address_class.h caml/printexc.h \
+ caml/signals.h caml/stacks.h
+finalise.o: finalise.c caml/callback.h caml/mlvalues.h caml/config.h \
+ caml/../../config/m.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/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/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
+ 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 \
- caml/io.h caml/md5.h caml/memory.h caml/gc.h caml/major_gc.h \
- caml/freelist.h caml/minor_gc.h caml/address_class.h caml/reverse.h
-floats.o: floats.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/reverse.h \
- caml/stacks.h
+ caml/../../config/s.h caml/debugger.h caml/misc.h caml/mlvalues.h \
+ caml/fix_code.h caml/instruct.h caml/intext.h caml/io.h caml/md5.h \
+ caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
+ caml/minor_gc.h caml/address_class.h caml/reverse.h
+floats.o: floats.c caml/alloc.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/reverse.h caml/stacks.h
freelist.o: freelist.c caml/config.h caml/../../config/m.h \
- caml/../../config/s.h caml/compatibility.h caml/freelist.h caml/misc.h \
- caml/mlvalues.h caml/gc.h caml/gc_ctrl.h caml/memory.h caml/major_gc.h \
- caml/minor_gc.h caml/address_class.h
-gc_ctrl.o: gc_ctrl.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/backtrace.h caml/exec.h caml/compact.h \
- caml/custom.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
- caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
- caml/address_class.h caml/gc_ctrl.h caml/signals.h caml/stacks.h \
- caml/startup_aux.h
-globroots.o: globroots.c caml/memory.h caml/compatibility.h caml/config.h \
+ caml/../../config/s.h caml/freelist.h caml/misc.h caml/mlvalues.h \
+ caml/gc.h caml/gc_ctrl.h caml/memory.h caml/major_gc.h caml/minor_gc.h \
+ caml/address_class.h
+gc_ctrl.o: gc_ctrl.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/backtrace.h caml/exec.h caml/compact.h caml/custom.h caml/fail.h \
+ caml/finalise.h caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h \
+ caml/freelist.h caml/minor_gc.h caml/address_class.h caml/gc_ctrl.h \
+ caml/signals.h caml/stacks.h caml/startup_aux.h
+globroots.o: globroots.c caml/memory.h caml/config.h \
caml/../../config/m.h caml/../../config/s.h caml/gc.h caml/mlvalues.h \
caml/misc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
caml/address_class.h caml/roots.h caml/globroots.h
-hash.o: hash.c caml/mlvalues.h caml/compatibility.h caml/config.h \
- caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/custom.h \
- caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
- caml/minor_gc.h caml/address_class.h caml/hash.h
+hash.o: hash.c caml/mlvalues.h caml/config.h caml/../../config/m.h \
+ caml/../../config/s.h caml/misc.h caml/custom.h caml/memory.h \
+ caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
+ caml/address_class.h caml/hash.h
instrtrace.o: instrtrace.c
-intern.o: intern.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/callback.h caml/custom.h caml/fail.h caml/gc.h \
- caml/intext.h caml/io.h caml/md5.h caml/memory.h caml/major_gc.h \
- caml/freelist.h caml/minor_gc.h caml/address_class.h caml/reverse.h
-interp.o: interp.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/backtrace.h caml/exec.h caml/callback.h \
- caml/debugger.h caml/fail.h caml/fix_code.h caml/instrtrace.h \
- caml/instruct.h caml/interp.h caml/major_gc.h caml/freelist.h \
- caml/memory.h caml/gc.h caml/minor_gc.h caml/address_class.h \
- caml/prims.h caml/signals.h caml/stacks.h caml/startup_aux.h \
- caml/jumptbl.h
-ints.o: ints.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/custom.h caml/fail.h caml/intext.h caml/io.h \
- caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
- caml/minor_gc.h caml/address_class.h
-io.o: io.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/custom.h caml/fail.h caml/io.h caml/memory.h caml/gc.h \
- caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
- caml/osdeps.h caml/signals.h caml/sys.h
-lexing.o: lexing.c caml/fail.h caml/compatibility.h caml/misc.h \
- caml/config.h caml/../../config/m.h caml/../../config/s.h \
- caml/mlvalues.h caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h \
- caml/freelist.h caml/minor_gc.h caml/address_class.h
-main.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/mlvalues.h \
- caml/custom.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
+intern.o: intern.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/callback.h caml/custom.h caml/fail.h caml/gc.h caml/intext.h \
+ caml/io.h caml/md5.h caml/memory.h caml/major_gc.h caml/freelist.h \
+ caml/minor_gc.h caml/address_class.h caml/reverse.h
+interp.o: interp.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/backtrace.h caml/exec.h caml/callback.h caml/debugger.h \
+ caml/fail.h caml/fix_code.h caml/instrtrace.h caml/instruct.h \
+ caml/interp.h caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \
+ caml/minor_gc.h caml/address_class.h caml/prims.h caml/signals.h \
+ caml/stacks.h caml/startup_aux.h caml/jumptbl.h
+ints.o: ints.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/custom.h caml/fail.h caml/intext.h caml/io.h caml/memory.h \
caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
- caml/address_class.h caml/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 \
+ caml/address_class.h
+io.o: io.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
+ caml/alloc.h caml/misc.h caml/mlvalues.h caml/custom.h caml/fail.h \
+ caml/io.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
+ caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \
+ caml/sys.h
+lexing.o: lexing.c caml/fail.h caml/misc.h caml/config.h \
caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
- caml/fail.h caml/md5.h caml/io.h caml/memory.h caml/gc.h \
- caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
- caml/reverse.h
-memory.o: memory.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/fail.h caml/freelist.h caml/gc.h \
- caml/gc_ctrl.h caml/major_gc.h caml/memory.h caml/minor_gc.h \
- caml/signals.h
-meta.o: meta.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/fix_code.h caml/interp.h \
- caml/intext.h caml/io.h caml/major_gc.h caml/freelist.h caml/memory.h \
- caml/gc.h caml/minor_gc.h caml/address_class.h caml/prims.h \
- caml/stacks.h
-minor_gc.o: minor_gc.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/stacks.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
+ caml/minor_gc.h caml/address_class.h
+main.o: main.c caml/misc.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/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/misc.h caml/config.h caml/../../config/m.h \
+ caml/../../config/s.h caml/mlvalues.h caml/fail.h caml/md5.h caml/io.h \
+ caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
+ caml/minor_gc.h caml/address_class.h caml/reverse.h
+memory.o: memory.c caml/address_class.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/misc.h \
+ caml/mlvalues.h caml/fail.h caml/freelist.h caml/gc.h caml/gc_ctrl.h \
+ caml/major_gc.h caml/memory.h caml/minor_gc.h caml/signals.h
+meta.o: meta.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/fail.h caml/fix_code.h caml/interp.h caml/intext.h caml/io.h \
+ caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \
+ caml/minor_gc.h caml/address_class.h caml/prims.h caml/stacks.h
+minor_gc.o: minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/misc.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
misc.o: misc.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
- caml/compatibility.h caml/misc.h caml/memory.h caml/gc.h \
+ caml/misc.h caml/memory.h caml/gc.h caml/mlvalues.h caml/major_gc.h \
+ caml/freelist.h caml/minor_gc.h caml/address_class.h caml/osdeps.h \
+ caml/version.h
+obj.o: obj.c caml/alloc.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/spacetime.h
+parsing.o: parsing.c caml/config.h caml/../../config/m.h \
+ caml/../../config/s.h caml/mlvalues.h caml/misc.h caml/memory.h \
+ caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
+ caml/address_class.h caml/alloc.h
+prims.o: prims.c caml/mlvalues.h caml/config.h caml/../../config/m.h \
+ caml/../../config/s.h caml/misc.h caml/prims.h
+printexc.o: printexc.c caml/backtrace.h caml/mlvalues.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/exec.h \
+ caml/callback.h caml/debugger.h caml/fail.h caml/printexc.h
+roots.o: roots.c caml/finalise.h caml/roots.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/memory.h caml/gc.h \
caml/mlvalues.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
- caml/address_class.h caml/version.h
-obj.o: obj.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \
+ caml/address_class.h caml/globroots.h caml/stacks.h
+signals.o: signals.c caml/alloc.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 \
- 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 \
- caml/minor_gc.h caml/address_class.h caml/alloc.h
-prims.o: prims.c caml/mlvalues.h caml/compatibility.h caml/config.h \
- caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/prims.h
-printexc.o: printexc.c caml/backtrace.h caml/mlvalues.h \
- caml/compatibility.h caml/config.h caml/../../config/m.h \
- caml/../../config/s.h caml/misc.h caml/exec.h caml/callback.h \
- caml/debugger.h caml/fail.h caml/printexc.h
-roots.o: roots.c caml/finalise.h caml/roots.h caml/misc.h \
- caml/compatibility.h caml/config.h caml/../../config/m.h \
- caml/../../config/s.h caml/memory.h caml/gc.h caml/mlvalues.h \
- caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
- caml/globroots.h caml/stacks.h
-signals.o: signals.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/callback.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/roots.h caml/signals.h caml/signals_machdep.h caml/sys.h
+ caml/callback.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/roots.h \
+ caml/signals.h caml/signals_machdep.h caml/sys.h
signals_byt.o: signals_byt.c caml/config.h caml/../../config/m.h \
- caml/../../config/s.h caml/compatibility.h caml/memory.h caml/gc.h \
- caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \
- caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \
+ caml/../../config/s.h caml/memory.h caml/gc.h caml/mlvalues.h \
+ caml/misc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
+ caml/address_class.h caml/osdeps.h caml/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
+spacetime.o: spacetime.c caml/fail.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 \
- caml/freelist.h caml/minor_gc.h caml/address_class.h
+ caml/../../config/s.h caml/fail.h caml/misc.h caml/mlvalues.h \
+ caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
+ caml/minor_gc.h caml/address_class.h
startup.o: startup.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/backtrace.h caml/exec.h caml/callback.h \
- caml/custom.h caml/debugger.h caml/dynlink.h caml/fail.h \
- caml/fix_code.h caml/freelist.h caml/gc_ctrl.h caml/instrtrace.h \
- caml/interp.h caml/intext.h caml/io.h caml/memory.h caml/gc.h \
- caml/major_gc.h caml/minor_gc.h caml/address_class.h caml/osdeps.h \
- caml/prims.h caml/printexc.h caml/reverse.h caml/signals.h \
- caml/stacks.h caml/sys.h caml/startup.h caml/startup_aux.h \
- caml/version.h
+ caml/../../config/s.h caml/alloc.h caml/misc.h caml/mlvalues.h \
+ caml/backtrace.h caml/exec.h caml/callback.h caml/custom.h \
+ caml/debugger.h caml/dynlink.h caml/fail.h caml/fix_code.h \
+ caml/freelist.h caml/gc_ctrl.h caml/instrtrace.h caml/interp.h \
+ caml/intext.h caml/io.h caml/memory.h caml/gc.h caml/major_gc.h \
+ caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/prims.h \
+ caml/printexc.h caml/reverse.h caml/signals.h caml/stacks.h caml/sys.h \
+ caml/startup.h caml/startup_aux.h caml/version.h
startup_aux.o: startup_aux.c caml/backtrace.h caml/mlvalues.h \
- caml/compatibility.h caml/config.h caml/../../config/m.h \
- caml/../../config/s.h caml/misc.h caml/exec.h caml/memory.h caml/gc.h \
- caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
- caml/startup_aux.h
-str.o: str.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/config.h caml/../../config/m.h caml/../../config/s.h caml/misc.h \
+ caml/exec.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
+ caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/startup_aux.h
+str.o: str.c caml/alloc.h caml/misc.h caml/config.h caml/../../config/m.h \
+ caml/../../config/s.h caml/mlvalues.h caml/fail.h
sys.o: sys.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/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/version.h
+ caml/alloc.h caml/misc.h caml/mlvalues.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/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
+ caml/../../config/s.h caml/alloc.h caml/misc.h caml/mlvalues.h \
+ caml/fail.h caml/io.h
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/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/io.h
+weak.o: weak.c caml/alloc.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 caml/memory.h caml/gc.h \
+ caml/minor_gc.h caml/address_class.h caml/weak.h
+afl.d.o: afl.c caml/misc.h caml/config.h caml/../../config/m.h \
+ caml/../../config/s.h caml/mlvalues.h caml/osdeps.h
+alloc.d.o: alloc.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/custom.h caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \
+ caml/minor_gc.h caml/address_class.h caml/stacks.h
+array.d.o: array.c caml/alloc.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/spacetime.h
+backtrace.d.o: backtrace.c caml/alloc.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 caml/freelist.h \
- caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.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 \
- caml/memory.h caml/gc.h caml/minor_gc.h caml/address_class.h \
- caml/weak.h
-alloc.d.o: alloc.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/custom.h caml/major_gc.h caml/freelist.h \
- caml/memory.h caml/gc.h caml/minor_gc.h caml/address_class.h \
- caml/stacks.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 \
- 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 \
- caml/freelist.h caml/minor_gc.h caml/address_class.h caml/backtrace.h \
- caml/exec.h caml/backtrace_prim.h caml/fail.h
+ caml/minor_gc.h caml/address_class.h caml/backtrace.h caml/exec.h \
+ caml/backtrace_prim.h caml/fail.h
backtrace_prim.d.o: backtrace_prim.c caml/config.h caml/../../config/m.h \
- caml/../../config/s.h caml/compatibility.h caml/mlvalues.h caml/misc.h \
- caml/alloc.h caml/custom.h caml/io.h caml/instruct.h caml/intext.h \
- caml/exec.h caml/fix_code.h caml/memory.h caml/gc.h caml/major_gc.h \
+ caml/../../config/s.h caml/mlvalues.h caml/misc.h caml/alloc.h \
+ caml/custom.h caml/io.h caml/instruct.h caml/intext.h caml/exec.h \
+ caml/fix_code.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/startup.h \
caml/stacks.h caml/sys.h caml/backtrace.h caml/fail.h \
caml/backtrace_prim.h
-callback.d.o: callback.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/memory.h caml/gc.h \
- caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
- caml/interp.h caml/instruct.h caml/fix_code.h caml/stacks.h
+callback.d.o: callback.c caml/callback.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 \
+ caml/minor_gc.h caml/address_class.h caml/interp.h caml/instruct.h \
+ caml/fix_code.h caml/stacks.h
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/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 \
+ caml/../../config/m.h caml/../../config/s.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/compact.h
+compare.d.o: compare.c caml/custom.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 \
caml/minor_gc.h caml/address_class.h
-custom.d.o: custom.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/custom.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
-debugger.d.o: debugger.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/debugger.h caml/fail.h caml/fix_code.h \
+custom.d.o: custom.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/custom.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
+debugger.d.o: debugger.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/debugger.h caml/osdeps.h caml/fail.h caml/fix_code.h \
caml/instruct.h caml/intext.h caml/io.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
dynlink.d.o: dynlink.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/dynlink.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/osdeps.h caml/prims.h caml/signals.h
-extern.d.o: extern.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/custom.h caml/fail.h caml/gc.h caml/intext.h \
- caml/io.h caml/md5.h caml/memory.h caml/major_gc.h caml/freelist.h \
- caml/minor_gc.h caml/address_class.h caml/reverse.h
-fail.d.o: fail.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/io.h caml/gc.h caml/memory.h \
+ caml/../../config/s.h caml/alloc.h caml/misc.h caml/mlvalues.h \
+ caml/dynlink.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/osdeps.h \
+ caml/prims.h caml/signals.h
+extern.d.o: extern.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/custom.h caml/fail.h caml/gc.h caml/intext.h caml/io.h caml/md5.h \
+ caml/memory.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
+ caml/address_class.h caml/reverse.h
+fail.d.o: fail.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/fail.h caml/io.h caml/gc.h caml/memory.h caml/major_gc.h \
+ caml/freelist.h caml/minor_gc.h caml/address_class.h caml/printexc.h \
+ caml/signals.h caml/stacks.h
+finalise.d.o: finalise.c caml/callback.h caml/mlvalues.h caml/config.h \
+ caml/../../config/m.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/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/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
+ 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 \
- caml/io.h caml/md5.h caml/memory.h caml/gc.h caml/major_gc.h \
- caml/freelist.h caml/minor_gc.h caml/address_class.h caml/reverse.h
-floats.d.o: floats.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/reverse.h \
- caml/stacks.h
+ caml/../../config/s.h caml/debugger.h caml/misc.h caml/mlvalues.h \
+ caml/fix_code.h caml/instruct.h caml/intext.h caml/io.h caml/md5.h \
+ caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
+ caml/minor_gc.h caml/address_class.h caml/reverse.h
+floats.d.o: floats.c caml/alloc.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/reverse.h caml/stacks.h
freelist.d.o: freelist.c caml/config.h caml/../../config/m.h \
- caml/../../config/s.h caml/compatibility.h caml/freelist.h caml/misc.h \
- caml/mlvalues.h caml/gc.h caml/gc_ctrl.h caml/memory.h caml/major_gc.h \
- caml/minor_gc.h caml/address_class.h
-gc_ctrl.d.o: gc_ctrl.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/backtrace.h caml/exec.h caml/compact.h \
- caml/custom.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
- caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
- caml/address_class.h caml/gc_ctrl.h caml/signals.h caml/stacks.h \
- caml/startup_aux.h
-globroots.d.o: globroots.c caml/memory.h caml/compatibility.h caml/config.h \
+ caml/../../config/s.h caml/freelist.h caml/misc.h caml/mlvalues.h \
+ caml/gc.h caml/gc_ctrl.h caml/memory.h caml/major_gc.h caml/minor_gc.h \
+ caml/address_class.h
+gc_ctrl.d.o: gc_ctrl.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/backtrace.h caml/exec.h caml/compact.h caml/custom.h caml/fail.h \
+ caml/finalise.h caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h \
+ caml/freelist.h caml/minor_gc.h caml/address_class.h caml/gc_ctrl.h \
+ caml/signals.h caml/stacks.h caml/startup_aux.h
+globroots.d.o: globroots.c caml/memory.h caml/config.h \
caml/../../config/m.h caml/../../config/s.h caml/gc.h caml/mlvalues.h \
caml/misc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
caml/address_class.h caml/roots.h caml/globroots.h
-hash.d.o: hash.c caml/mlvalues.h caml/compatibility.h caml/config.h \
- caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/custom.h \
- caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
- caml/minor_gc.h caml/address_class.h caml/hash.h
+hash.d.o: hash.c caml/mlvalues.h caml/config.h caml/../../config/m.h \
+ caml/../../config/s.h caml/misc.h caml/custom.h caml/memory.h \
+ caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
+ caml/address_class.h caml/hash.h
instrtrace.d.o: instrtrace.c caml/instrtrace.h caml/mlvalues.h \
- caml/compatibility.h caml/config.h caml/../../config/m.h \
- caml/../../config/s.h caml/misc.h caml/instruct.h caml/opnames.h \
- caml/prims.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/startup_aux.h
-intern.d.o: intern.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/callback.h caml/custom.h caml/fail.h caml/gc.h \
- caml/intext.h caml/io.h caml/md5.h caml/memory.h caml/major_gc.h \
- caml/freelist.h caml/minor_gc.h caml/address_class.h caml/reverse.h
-interp.d.o: interp.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/backtrace.h caml/exec.h caml/callback.h \
- caml/debugger.h caml/fail.h caml/fix_code.h caml/instrtrace.h \
- caml/instruct.h caml/interp.h caml/major_gc.h caml/freelist.h \
- caml/memory.h caml/gc.h caml/minor_gc.h caml/address_class.h \
- caml/prims.h caml/signals.h caml/stacks.h caml/startup_aux.h
-ints.d.o: ints.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/custom.h caml/fail.h caml/intext.h caml/io.h \
+ caml/config.h caml/../../config/m.h caml/../../config/s.h caml/misc.h \
+ caml/instruct.h caml/opnames.h caml/prims.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
-io.d.o: io.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/custom.h caml/fail.h caml/io.h caml/memory.h caml/gc.h \
- caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
- caml/osdeps.h caml/signals.h caml/sys.h
-lexing.d.o: lexing.c caml/fail.h caml/compatibility.h caml/misc.h \
- caml/config.h caml/../../config/m.h caml/../../config/s.h \
- caml/mlvalues.h caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h \
- caml/freelist.h caml/minor_gc.h caml/address_class.h
-main.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/mlvalues.h \
- caml/custom.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
+ caml/minor_gc.h caml/address_class.h caml/startup_aux.h
+intern.d.o: intern.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/callback.h caml/custom.h caml/fail.h caml/gc.h caml/intext.h \
+ caml/io.h caml/md5.h caml/memory.h caml/major_gc.h caml/freelist.h \
+ caml/minor_gc.h caml/address_class.h caml/reverse.h
+interp.d.o: interp.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/backtrace.h caml/exec.h caml/callback.h caml/debugger.h \
+ caml/fail.h caml/fix_code.h caml/instrtrace.h caml/instruct.h \
+ caml/interp.h caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \
+ caml/minor_gc.h caml/address_class.h caml/prims.h caml/signals.h \
+ caml/stacks.h caml/startup_aux.h
+ints.d.o: ints.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/custom.h caml/fail.h caml/intext.h caml/io.h caml/memory.h \
caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
- caml/address_class.h caml/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 \
+ caml/address_class.h
+io.d.o: io.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
+ caml/alloc.h caml/misc.h caml/mlvalues.h caml/custom.h caml/fail.h \
+ caml/io.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
+ caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \
+ caml/sys.h
+lexing.d.o: lexing.c caml/fail.h caml/misc.h caml/config.h \
caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
- caml/fail.h caml/md5.h caml/io.h caml/memory.h caml/gc.h \
- caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
- caml/reverse.h
-memory.d.o: memory.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/fail.h caml/freelist.h caml/gc.h \
- caml/gc_ctrl.h caml/major_gc.h caml/memory.h caml/minor_gc.h \
- caml/signals.h
-meta.d.o: meta.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/fix_code.h caml/interp.h \
- caml/intext.h caml/io.h caml/major_gc.h caml/freelist.h caml/memory.h \
- caml/gc.h caml/minor_gc.h caml/address_class.h caml/prims.h \
- caml/stacks.h
-minor_gc.d.o: minor_gc.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/stacks.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
+ caml/minor_gc.h caml/address_class.h
+main.d.o: main.c caml/misc.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/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/misc.h caml/config.h caml/../../config/m.h \
+ caml/../../config/s.h caml/mlvalues.h caml/fail.h caml/md5.h caml/io.h \
+ caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
+ caml/minor_gc.h caml/address_class.h caml/reverse.h
+memory.d.o: memory.c caml/address_class.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/misc.h \
+ caml/mlvalues.h caml/fail.h caml/freelist.h caml/gc.h caml/gc_ctrl.h \
+ caml/major_gc.h caml/memory.h caml/minor_gc.h caml/signals.h
+meta.d.o: meta.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/fail.h caml/fix_code.h caml/interp.h caml/intext.h caml/io.h \
+ caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \
+ caml/minor_gc.h caml/address_class.h caml/prims.h caml/stacks.h
+minor_gc.d.o: minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/misc.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
misc.d.o: misc.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
- caml/compatibility.h caml/misc.h caml/memory.h caml/gc.h \
+ caml/misc.h caml/memory.h caml/gc.h caml/mlvalues.h caml/major_gc.h \
+ caml/freelist.h caml/minor_gc.h caml/address_class.h caml/osdeps.h \
+ caml/version.h
+obj.d.o: obj.c caml/alloc.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/spacetime.h
+parsing.d.o: parsing.c caml/config.h caml/../../config/m.h \
+ caml/../../config/s.h caml/mlvalues.h caml/misc.h caml/memory.h \
+ caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
+ caml/address_class.h caml/alloc.h
+prims.d.o: prims.c caml/mlvalues.h caml/config.h caml/../../config/m.h \
+ caml/../../config/s.h caml/misc.h caml/prims.h
+printexc.d.o: printexc.c caml/backtrace.h caml/mlvalues.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/exec.h \
+ caml/callback.h caml/debugger.h caml/fail.h caml/printexc.h
+roots.d.o: roots.c caml/finalise.h caml/roots.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/memory.h caml/gc.h \
caml/mlvalues.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
- caml/address_class.h caml/version.h
-obj.d.o: obj.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \
+ caml/address_class.h caml/globroots.h caml/stacks.h
+signals.d.o: signals.c caml/alloc.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 \
- 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 \
- caml/minor_gc.h caml/address_class.h caml/alloc.h
-prims.d.o: prims.c caml/mlvalues.h caml/compatibility.h caml/config.h \
- caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/prims.h
-printexc.d.o: printexc.c caml/backtrace.h caml/mlvalues.h \
- caml/compatibility.h caml/config.h caml/../../config/m.h \
- caml/../../config/s.h caml/misc.h caml/exec.h caml/callback.h \
- caml/debugger.h caml/fail.h caml/printexc.h
-roots.d.o: roots.c caml/finalise.h caml/roots.h caml/misc.h \
- caml/compatibility.h caml/config.h caml/../../config/m.h \
- caml/../../config/s.h caml/memory.h caml/gc.h caml/mlvalues.h \
- caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
- caml/globroots.h caml/stacks.h
-signals.d.o: signals.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/callback.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/roots.h caml/signals.h caml/signals_machdep.h caml/sys.h
+ caml/callback.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/roots.h \
+ caml/signals.h caml/signals_machdep.h caml/sys.h
signals_byt.d.o: signals_byt.c caml/config.h caml/../../config/m.h \
- caml/../../config/s.h caml/compatibility.h caml/memory.h caml/gc.h \
- caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \
- caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \
+ caml/../../config/s.h caml/memory.h caml/gc.h caml/mlvalues.h \
+ caml/misc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
+ caml/address_class.h caml/osdeps.h caml/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
+spacetime.d.o: spacetime.c caml/fail.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 \
- caml/freelist.h caml/minor_gc.h caml/address_class.h
+ caml/../../config/s.h caml/fail.h caml/misc.h caml/mlvalues.h \
+ caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
+ caml/minor_gc.h caml/address_class.h
startup.d.o: startup.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/backtrace.h caml/exec.h caml/callback.h \
- caml/custom.h caml/debugger.h caml/dynlink.h caml/fail.h \
- caml/fix_code.h caml/freelist.h caml/gc_ctrl.h caml/instrtrace.h \
- caml/interp.h caml/intext.h caml/io.h caml/memory.h caml/gc.h \
- caml/major_gc.h caml/minor_gc.h caml/address_class.h caml/osdeps.h \
- caml/prims.h caml/printexc.h caml/reverse.h caml/signals.h \
- caml/stacks.h caml/sys.h caml/startup.h caml/startup_aux.h \
- caml/version.h
+ caml/../../config/s.h caml/alloc.h caml/misc.h caml/mlvalues.h \
+ caml/backtrace.h caml/exec.h caml/callback.h caml/custom.h \
+ caml/debugger.h caml/dynlink.h caml/fail.h caml/fix_code.h \
+ caml/freelist.h caml/gc_ctrl.h caml/instrtrace.h caml/interp.h \
+ caml/intext.h caml/io.h caml/memory.h caml/gc.h caml/major_gc.h \
+ caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/prims.h \
+ caml/printexc.h caml/reverse.h caml/signals.h caml/stacks.h caml/sys.h \
+ caml/startup.h caml/startup_aux.h caml/version.h
startup_aux.d.o: startup_aux.c caml/backtrace.h caml/mlvalues.h \
- caml/compatibility.h caml/config.h caml/../../config/m.h \
- caml/../../config/s.h caml/misc.h caml/exec.h caml/memory.h caml/gc.h \
- caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
- caml/startup_aux.h
-str.d.o: str.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/config.h caml/../../config/m.h caml/../../config/s.h caml/misc.h \
+ caml/exec.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
+ caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/startup_aux.h
+str.d.o: str.c caml/alloc.h caml/misc.h caml/config.h caml/../../config/m.h \
+ caml/../../config/s.h caml/mlvalues.h caml/fail.h
sys.d.o: sys.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/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/version.h
+ caml/alloc.h caml/misc.h caml/mlvalues.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/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
+ caml/../../config/s.h caml/alloc.h caml/misc.h caml/mlvalues.h \
+ caml/fail.h caml/io.h
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/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/io.h
+weak.d.o: weak.c caml/alloc.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 caml/memory.h caml/gc.h \
+ caml/minor_gc.h caml/address_class.h caml/weak.h
+afl.i.o: afl.c caml/misc.h caml/config.h caml/../../config/m.h \
+ caml/../../config/s.h caml/mlvalues.h caml/osdeps.h
+alloc.i.o: alloc.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/custom.h caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \
+ caml/minor_gc.h caml/address_class.h caml/stacks.h
+array.i.o: array.c caml/alloc.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/spacetime.h
+backtrace.i.o: backtrace.c caml/alloc.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 caml/freelist.h \
- caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.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 \
- caml/memory.h caml/gc.h caml/minor_gc.h caml/address_class.h \
- caml/weak.h
-alloc.i.o: alloc.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/custom.h caml/major_gc.h caml/freelist.h \
- caml/memory.h caml/gc.h caml/minor_gc.h caml/address_class.h \
- caml/stacks.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 \
- 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 \
- caml/freelist.h caml/minor_gc.h caml/address_class.h caml/backtrace.h \
- caml/exec.h caml/backtrace_prim.h caml/fail.h
+ caml/minor_gc.h caml/address_class.h caml/backtrace.h caml/exec.h \
+ caml/backtrace_prim.h caml/fail.h
backtrace_prim.i.o: backtrace_prim.c caml/config.h caml/../../config/m.h \
- caml/../../config/s.h caml/compatibility.h caml/mlvalues.h caml/misc.h \
- caml/alloc.h caml/custom.h caml/io.h caml/instruct.h caml/intext.h \
- caml/exec.h caml/fix_code.h caml/memory.h caml/gc.h caml/major_gc.h \
+ caml/../../config/s.h caml/mlvalues.h caml/misc.h caml/alloc.h \
+ caml/custom.h caml/io.h caml/instruct.h caml/intext.h caml/exec.h \
+ caml/fix_code.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/startup.h \
caml/stacks.h caml/sys.h caml/backtrace.h caml/fail.h \
caml/backtrace_prim.h
-callback.i.o: callback.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/memory.h caml/gc.h \
- caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
- caml/interp.h caml/instruct.h caml/fix_code.h caml/stacks.h
+callback.i.o: callback.c caml/callback.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 \
+ caml/minor_gc.h caml/address_class.h caml/interp.h caml/instruct.h \
+ caml/fix_code.h caml/stacks.h
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/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 \
+ caml/../../config/m.h caml/../../config/s.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/compact.h
+compare.i.o: compare.c caml/custom.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 \
caml/minor_gc.h caml/address_class.h
-custom.i.o: custom.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/custom.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
-debugger.i.o: debugger.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/debugger.h caml/fail.h caml/fix_code.h \
+custom.i.o: custom.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/custom.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
+debugger.i.o: debugger.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/debugger.h caml/osdeps.h caml/fail.h caml/fix_code.h \
caml/instruct.h caml/intext.h caml/io.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
dynlink.i.o: dynlink.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/dynlink.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/osdeps.h caml/prims.h caml/signals.h
-extern.i.o: extern.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/custom.h caml/fail.h caml/gc.h caml/intext.h \
- caml/io.h caml/md5.h caml/memory.h caml/major_gc.h caml/freelist.h \
- caml/minor_gc.h caml/address_class.h caml/reverse.h
-fail.i.o: fail.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/io.h caml/gc.h caml/memory.h \
+ caml/../../config/s.h caml/alloc.h caml/misc.h caml/mlvalues.h \
+ caml/dynlink.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/osdeps.h \
+ caml/prims.h caml/signals.h
+extern.i.o: extern.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/custom.h caml/fail.h caml/gc.h caml/intext.h caml/io.h caml/md5.h \
+ caml/memory.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
+ caml/address_class.h caml/reverse.h
+fail.i.o: fail.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/fail.h caml/io.h caml/gc.h caml/memory.h caml/major_gc.h \
+ caml/freelist.h caml/minor_gc.h caml/address_class.h caml/printexc.h \
+ caml/signals.h caml/stacks.h
+finalise.i.o: finalise.c caml/callback.h caml/mlvalues.h caml/config.h \
+ caml/../../config/m.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/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/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
+ 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 \
- caml/io.h caml/md5.h caml/memory.h caml/gc.h caml/major_gc.h \
- caml/freelist.h caml/minor_gc.h caml/address_class.h caml/reverse.h
-floats.i.o: floats.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/reverse.h \
- caml/stacks.h
+ caml/../../config/s.h caml/debugger.h caml/misc.h caml/mlvalues.h \
+ caml/fix_code.h caml/instruct.h caml/intext.h caml/io.h caml/md5.h \
+ caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
+ caml/minor_gc.h caml/address_class.h caml/reverse.h
+floats.i.o: floats.c caml/alloc.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/reverse.h caml/stacks.h
freelist.i.o: freelist.c caml/config.h caml/../../config/m.h \
- caml/../../config/s.h caml/compatibility.h caml/freelist.h caml/misc.h \
- caml/mlvalues.h caml/gc.h caml/gc_ctrl.h caml/memory.h caml/major_gc.h \
- caml/minor_gc.h caml/address_class.h
-gc_ctrl.i.o: gc_ctrl.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/backtrace.h caml/exec.h caml/compact.h \
- caml/custom.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
- caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
- caml/address_class.h caml/gc_ctrl.h caml/signals.h caml/stacks.h \
- caml/startup_aux.h
-globroots.i.o: globroots.c caml/memory.h caml/compatibility.h caml/config.h \
+ caml/../../config/s.h caml/freelist.h caml/misc.h caml/mlvalues.h \
+ caml/gc.h caml/gc_ctrl.h caml/memory.h caml/major_gc.h caml/minor_gc.h \
+ caml/address_class.h
+gc_ctrl.i.o: gc_ctrl.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/backtrace.h caml/exec.h caml/compact.h caml/custom.h caml/fail.h \
+ caml/finalise.h caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h \
+ caml/freelist.h caml/minor_gc.h caml/address_class.h caml/gc_ctrl.h \
+ caml/signals.h caml/stacks.h caml/startup_aux.h
+globroots.i.o: globroots.c caml/memory.h caml/config.h \
caml/../../config/m.h caml/../../config/s.h caml/gc.h caml/mlvalues.h \
caml/misc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
caml/address_class.h caml/roots.h caml/globroots.h
-hash.i.o: hash.c caml/mlvalues.h caml/compatibility.h caml/config.h \
- caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/custom.h \
- caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
- caml/minor_gc.h caml/address_class.h caml/hash.h
+hash.i.o: hash.c caml/mlvalues.h caml/config.h caml/../../config/m.h \
+ caml/../../config/s.h caml/misc.h caml/custom.h caml/memory.h \
+ caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
+ caml/address_class.h caml/hash.h
instrtrace.i.o: instrtrace.c
-intern.i.o: intern.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/callback.h caml/custom.h caml/fail.h caml/gc.h \
- caml/intext.h caml/io.h caml/md5.h caml/memory.h caml/major_gc.h \
- caml/freelist.h caml/minor_gc.h caml/address_class.h caml/reverse.h
-interp.i.o: interp.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/backtrace.h caml/exec.h caml/callback.h \
- caml/debugger.h caml/fail.h caml/fix_code.h caml/instrtrace.h \
- caml/instruct.h caml/interp.h caml/major_gc.h caml/freelist.h \
- caml/memory.h caml/gc.h caml/minor_gc.h caml/address_class.h \
- caml/prims.h caml/signals.h caml/stacks.h caml/startup_aux.h \
- caml/jumptbl.h
-ints.i.o: ints.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/custom.h caml/fail.h caml/intext.h caml/io.h \
- caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
- caml/minor_gc.h caml/address_class.h
-io.i.o: io.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/custom.h caml/fail.h caml/io.h caml/memory.h caml/gc.h \
- caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
- caml/osdeps.h caml/signals.h caml/sys.h
-lexing.i.o: lexing.c caml/fail.h caml/compatibility.h caml/misc.h \
- caml/config.h caml/../../config/m.h caml/../../config/s.h \
- caml/mlvalues.h caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h \
- caml/freelist.h caml/minor_gc.h caml/address_class.h
-main.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/mlvalues.h \
- caml/custom.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
+intern.i.o: intern.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/callback.h caml/custom.h caml/fail.h caml/gc.h caml/intext.h \
+ caml/io.h caml/md5.h caml/memory.h caml/major_gc.h caml/freelist.h \
+ caml/minor_gc.h caml/address_class.h caml/reverse.h
+interp.i.o: interp.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/backtrace.h caml/exec.h caml/callback.h caml/debugger.h \
+ caml/fail.h caml/fix_code.h caml/instrtrace.h caml/instruct.h \
+ caml/interp.h caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \
+ caml/minor_gc.h caml/address_class.h caml/prims.h caml/signals.h \
+ caml/stacks.h caml/startup_aux.h caml/jumptbl.h
+ints.i.o: ints.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/custom.h caml/fail.h caml/intext.h caml/io.h caml/memory.h \
caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
- caml/address_class.h caml/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 \
+ caml/address_class.h
+io.i.o: io.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
+ caml/alloc.h caml/misc.h caml/mlvalues.h caml/custom.h caml/fail.h \
+ caml/io.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
+ caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \
+ caml/sys.h
+lexing.i.o: lexing.c caml/fail.h caml/misc.h caml/config.h \
caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
- caml/fail.h caml/md5.h caml/io.h caml/memory.h caml/gc.h \
- caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
- caml/reverse.h
-memory.i.o: memory.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/fail.h caml/freelist.h caml/gc.h \
- caml/gc_ctrl.h caml/major_gc.h caml/memory.h caml/minor_gc.h \
- caml/signals.h
-meta.i.o: meta.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/fix_code.h caml/interp.h \
- caml/intext.h caml/io.h caml/major_gc.h caml/freelist.h caml/memory.h \
- caml/gc.h caml/minor_gc.h caml/address_class.h caml/prims.h \
- caml/stacks.h
-minor_gc.i.o: minor_gc.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/stacks.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
+ caml/minor_gc.h caml/address_class.h
+main.i.o: main.c caml/misc.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/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/misc.h caml/config.h caml/../../config/m.h \
+ caml/../../config/s.h caml/mlvalues.h caml/fail.h caml/md5.h caml/io.h \
+ caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
+ caml/minor_gc.h caml/address_class.h caml/reverse.h
+memory.i.o: memory.c caml/address_class.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/misc.h \
+ caml/mlvalues.h caml/fail.h caml/freelist.h caml/gc.h caml/gc_ctrl.h \
+ caml/major_gc.h caml/memory.h caml/minor_gc.h caml/signals.h
+meta.i.o: meta.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/fail.h caml/fix_code.h caml/interp.h caml/intext.h caml/io.h \
+ caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \
+ caml/minor_gc.h caml/address_class.h caml/prims.h caml/stacks.h
+minor_gc.i.o: minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/misc.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
misc.i.o: misc.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
- caml/compatibility.h caml/misc.h caml/memory.h caml/gc.h \
+ caml/misc.h caml/memory.h caml/gc.h caml/mlvalues.h caml/major_gc.h \
+ caml/freelist.h caml/minor_gc.h caml/address_class.h caml/osdeps.h \
+ caml/version.h
+obj.i.o: obj.c caml/alloc.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/spacetime.h
+parsing.i.o: parsing.c caml/config.h caml/../../config/m.h \
+ caml/../../config/s.h caml/mlvalues.h caml/misc.h caml/memory.h \
+ caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
+ caml/address_class.h caml/alloc.h
+prims.i.o: prims.c caml/mlvalues.h caml/config.h caml/../../config/m.h \
+ caml/../../config/s.h caml/misc.h caml/prims.h
+printexc.i.o: printexc.c caml/backtrace.h caml/mlvalues.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/exec.h \
+ caml/callback.h caml/debugger.h caml/fail.h caml/printexc.h
+roots.i.o: roots.c caml/finalise.h caml/roots.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/memory.h caml/gc.h \
caml/mlvalues.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
- caml/address_class.h caml/version.h
-obj.i.o: obj.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \
+ caml/address_class.h caml/globroots.h caml/stacks.h
+signals.i.o: signals.c caml/alloc.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 \
- 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 \
- caml/minor_gc.h caml/address_class.h caml/alloc.h
-prims.i.o: prims.c caml/mlvalues.h caml/compatibility.h caml/config.h \
- caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/prims.h
-printexc.i.o: printexc.c caml/backtrace.h caml/mlvalues.h \
- caml/compatibility.h caml/config.h caml/../../config/m.h \
- caml/../../config/s.h caml/misc.h caml/exec.h caml/callback.h \
- caml/debugger.h caml/fail.h caml/printexc.h
-roots.i.o: roots.c caml/finalise.h caml/roots.h caml/misc.h \
- caml/compatibility.h caml/config.h caml/../../config/m.h \
- caml/../../config/s.h caml/memory.h caml/gc.h caml/mlvalues.h \
- caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
- caml/globroots.h caml/stacks.h
-signals.i.o: signals.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/callback.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/roots.h caml/signals.h caml/signals_machdep.h caml/sys.h
+ caml/callback.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/roots.h \
+ caml/signals.h caml/signals_machdep.h caml/sys.h
signals_byt.i.o: signals_byt.c caml/config.h caml/../../config/m.h \
- caml/../../config/s.h caml/compatibility.h caml/memory.h caml/gc.h \
- caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \
- caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \
+ caml/../../config/s.h caml/memory.h caml/gc.h caml/mlvalues.h \
+ caml/misc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
+ caml/address_class.h caml/osdeps.h caml/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
+spacetime.i.o: spacetime.c caml/fail.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 \
- caml/freelist.h caml/minor_gc.h caml/address_class.h
+ caml/../../config/s.h caml/fail.h caml/misc.h caml/mlvalues.h \
+ caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
+ caml/minor_gc.h caml/address_class.h
startup.i.o: startup.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/backtrace.h caml/exec.h caml/callback.h \
- caml/custom.h caml/debugger.h caml/dynlink.h caml/fail.h \
- caml/fix_code.h caml/freelist.h caml/gc_ctrl.h caml/instrtrace.h \
- caml/interp.h caml/intext.h caml/io.h caml/memory.h caml/gc.h \
- caml/major_gc.h caml/minor_gc.h caml/address_class.h caml/osdeps.h \
- caml/prims.h caml/printexc.h caml/reverse.h caml/signals.h \
- caml/stacks.h caml/sys.h caml/startup.h caml/startup_aux.h \
- caml/version.h
+ caml/../../config/s.h caml/alloc.h caml/misc.h caml/mlvalues.h \
+ caml/backtrace.h caml/exec.h caml/callback.h caml/custom.h \
+ caml/debugger.h caml/dynlink.h caml/fail.h caml/fix_code.h \
+ caml/freelist.h caml/gc_ctrl.h caml/instrtrace.h caml/interp.h \
+ caml/intext.h caml/io.h caml/memory.h caml/gc.h caml/major_gc.h \
+ caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/prims.h \
+ caml/printexc.h caml/reverse.h caml/signals.h caml/stacks.h caml/sys.h \
+ caml/startup.h caml/startup_aux.h caml/version.h
startup_aux.i.o: startup_aux.c caml/backtrace.h caml/mlvalues.h \
- caml/compatibility.h caml/config.h caml/../../config/m.h \
- caml/../../config/s.h caml/misc.h caml/exec.h caml/memory.h caml/gc.h \
- caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
- caml/startup_aux.h
-str.i.o: str.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/config.h caml/../../config/m.h caml/../../config/s.h caml/misc.h \
+ caml/exec.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
+ caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/startup_aux.h
+str.i.o: str.c caml/alloc.h caml/misc.h caml/config.h caml/../../config/m.h \
+ caml/../../config/s.h caml/mlvalues.h caml/fail.h
sys.i.o: sys.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/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/version.h
+ caml/alloc.h caml/misc.h caml/mlvalues.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/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
+ caml/../../config/s.h caml/alloc.h caml/misc.h caml/mlvalues.h \
+ caml/fail.h caml/io.h
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/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/io.h
+weak.i.o: weak.c caml/alloc.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 caml/memory.h caml/gc.h \
+ caml/minor_gc.h caml/address_class.h caml/weak.h
+afl.pic.o: afl.c caml/misc.h caml/config.h caml/../../config/m.h \
+ caml/../../config/s.h caml/mlvalues.h caml/osdeps.h
+alloc.pic.o: alloc.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/custom.h caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \
+ caml/minor_gc.h caml/address_class.h caml/stacks.h
+array.pic.o: array.c caml/alloc.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/spacetime.h
+backtrace.pic.o: backtrace.c caml/alloc.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 caml/freelist.h \
- caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.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 \
- caml/memory.h caml/gc.h caml/minor_gc.h caml/address_class.h \
- caml/weak.h
-alloc.pic.o: alloc.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/custom.h caml/major_gc.h caml/freelist.h \
- caml/memory.h caml/gc.h caml/minor_gc.h caml/address_class.h \
- caml/stacks.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 \
- 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 \
- caml/freelist.h caml/minor_gc.h caml/address_class.h caml/backtrace.h \
- caml/exec.h caml/backtrace_prim.h caml/fail.h
+ caml/minor_gc.h caml/address_class.h caml/backtrace.h caml/exec.h \
+ caml/backtrace_prim.h caml/fail.h
backtrace_prim.pic.o: backtrace_prim.c caml/config.h caml/../../config/m.h \
- caml/../../config/s.h caml/compatibility.h caml/mlvalues.h caml/misc.h \
- caml/alloc.h caml/custom.h caml/io.h caml/instruct.h caml/intext.h \
- caml/exec.h caml/fix_code.h caml/memory.h caml/gc.h caml/major_gc.h \
+ caml/../../config/s.h caml/mlvalues.h caml/misc.h caml/alloc.h \
+ caml/custom.h caml/io.h caml/instruct.h caml/intext.h caml/exec.h \
+ caml/fix_code.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/startup.h \
caml/stacks.h caml/sys.h caml/backtrace.h caml/fail.h \
caml/backtrace_prim.h
-callback.pic.o: callback.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/memory.h caml/gc.h \
- caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
- caml/interp.h caml/instruct.h caml/fix_code.h caml/stacks.h
+callback.pic.o: callback.c caml/callback.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 \
+ caml/minor_gc.h caml/address_class.h caml/interp.h caml/instruct.h \
+ caml/fix_code.h caml/stacks.h
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/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 \
+ caml/../../config/m.h caml/../../config/s.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/compact.h
+compare.pic.o: compare.c caml/custom.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 \
caml/minor_gc.h caml/address_class.h
-custom.pic.o: custom.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/custom.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
-debugger.pic.o: debugger.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/debugger.h caml/fail.h caml/fix_code.h \
+custom.pic.o: custom.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/custom.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
+debugger.pic.o: debugger.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/debugger.h caml/osdeps.h caml/fail.h caml/fix_code.h \
caml/instruct.h caml/intext.h caml/io.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
dynlink.pic.o: dynlink.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/dynlink.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/osdeps.h caml/prims.h caml/signals.h
-extern.pic.o: extern.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/custom.h caml/fail.h caml/gc.h caml/intext.h \
- caml/io.h caml/md5.h caml/memory.h caml/major_gc.h caml/freelist.h \
- caml/minor_gc.h caml/address_class.h caml/reverse.h
-fail.pic.o: fail.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/io.h caml/gc.h caml/memory.h \
+ caml/../../config/s.h caml/alloc.h caml/misc.h caml/mlvalues.h \
+ caml/dynlink.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/osdeps.h \
+ caml/prims.h caml/signals.h
+extern.pic.o: extern.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/custom.h caml/fail.h caml/gc.h caml/intext.h caml/io.h caml/md5.h \
+ caml/memory.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
+ caml/address_class.h caml/reverse.h
+fail.pic.o: fail.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/fail.h caml/io.h caml/gc.h caml/memory.h caml/major_gc.h \
+ caml/freelist.h caml/minor_gc.h caml/address_class.h caml/printexc.h \
+ caml/signals.h caml/stacks.h
+finalise.pic.o: finalise.c caml/callback.h caml/mlvalues.h caml/config.h \
+ caml/../../config/m.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/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/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
+ 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 \
- caml/io.h caml/md5.h caml/memory.h caml/gc.h caml/major_gc.h \
- caml/freelist.h caml/minor_gc.h caml/address_class.h caml/reverse.h
-floats.pic.o: floats.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/reverse.h \
- caml/stacks.h
+ caml/../../config/s.h caml/debugger.h caml/misc.h caml/mlvalues.h \
+ caml/fix_code.h caml/instruct.h caml/intext.h caml/io.h caml/md5.h \
+ caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
+ caml/minor_gc.h caml/address_class.h caml/reverse.h
+floats.pic.o: floats.c caml/alloc.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/reverse.h caml/stacks.h
freelist.pic.o: freelist.c caml/config.h caml/../../config/m.h \
- caml/../../config/s.h caml/compatibility.h caml/freelist.h caml/misc.h \
- caml/mlvalues.h caml/gc.h caml/gc_ctrl.h caml/memory.h caml/major_gc.h \
- caml/minor_gc.h caml/address_class.h
-gc_ctrl.pic.o: gc_ctrl.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/backtrace.h caml/exec.h caml/compact.h \
- caml/custom.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
- caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
- caml/address_class.h caml/gc_ctrl.h caml/signals.h caml/stacks.h \
- caml/startup_aux.h
-globroots.pic.o: globroots.c caml/memory.h caml/compatibility.h caml/config.h \
+ caml/../../config/s.h caml/freelist.h caml/misc.h caml/mlvalues.h \
+ caml/gc.h caml/gc_ctrl.h caml/memory.h caml/major_gc.h caml/minor_gc.h \
+ caml/address_class.h
+gc_ctrl.pic.o: gc_ctrl.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/backtrace.h caml/exec.h caml/compact.h caml/custom.h caml/fail.h \
+ caml/finalise.h caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h \
+ caml/freelist.h caml/minor_gc.h caml/address_class.h caml/gc_ctrl.h \
+ caml/signals.h caml/stacks.h caml/startup_aux.h
+globroots.pic.o: globroots.c caml/memory.h caml/config.h \
caml/../../config/m.h caml/../../config/s.h caml/gc.h caml/mlvalues.h \
caml/misc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
caml/address_class.h caml/roots.h caml/globroots.h
-hash.pic.o: hash.c caml/mlvalues.h caml/compatibility.h caml/config.h \
- caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/custom.h \
- caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
- caml/minor_gc.h caml/address_class.h caml/hash.h
+hash.pic.o: hash.c caml/mlvalues.h caml/config.h caml/../../config/m.h \
+ caml/../../config/s.h caml/misc.h caml/custom.h caml/memory.h \
+ caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
+ caml/address_class.h caml/hash.h
instrtrace.pic.o: instrtrace.c
-intern.pic.o: intern.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/callback.h caml/custom.h caml/fail.h caml/gc.h \
- caml/intext.h caml/io.h caml/md5.h caml/memory.h caml/major_gc.h \
- caml/freelist.h caml/minor_gc.h caml/address_class.h caml/reverse.h
-interp.pic.o: interp.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/backtrace.h caml/exec.h caml/callback.h \
- caml/debugger.h caml/fail.h caml/fix_code.h caml/instrtrace.h \
- caml/instruct.h caml/interp.h caml/major_gc.h caml/freelist.h \
- caml/memory.h caml/gc.h caml/minor_gc.h caml/address_class.h \
- caml/prims.h caml/signals.h caml/stacks.h caml/startup_aux.h \
- caml/jumptbl.h
-ints.pic.o: ints.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/custom.h caml/fail.h caml/intext.h caml/io.h \
- caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
- caml/minor_gc.h caml/address_class.h
-io.pic.o: io.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/custom.h caml/fail.h caml/io.h caml/memory.h caml/gc.h \
- caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
- caml/osdeps.h caml/signals.h caml/sys.h
-lexing.pic.o: lexing.c caml/fail.h caml/compatibility.h caml/misc.h \
- caml/config.h caml/../../config/m.h caml/../../config/s.h \
- caml/mlvalues.h caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h \
- caml/freelist.h caml/minor_gc.h caml/address_class.h
-main.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/mlvalues.h \
- caml/custom.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
+intern.pic.o: intern.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/callback.h caml/custom.h caml/fail.h caml/gc.h caml/intext.h \
+ caml/io.h caml/md5.h caml/memory.h caml/major_gc.h caml/freelist.h \
+ caml/minor_gc.h caml/address_class.h caml/reverse.h
+interp.pic.o: interp.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/backtrace.h caml/exec.h caml/callback.h caml/debugger.h \
+ caml/fail.h caml/fix_code.h caml/instrtrace.h caml/instruct.h \
+ caml/interp.h caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \
+ caml/minor_gc.h caml/address_class.h caml/prims.h caml/signals.h \
+ caml/stacks.h caml/startup_aux.h caml/jumptbl.h
+ints.pic.o: ints.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/custom.h caml/fail.h caml/intext.h caml/io.h caml/memory.h \
caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
- caml/address_class.h caml/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 \
+ caml/address_class.h
+io.pic.o: io.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
+ caml/alloc.h caml/misc.h caml/mlvalues.h caml/custom.h caml/fail.h \
+ caml/io.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
+ caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \
+ caml/sys.h
+lexing.pic.o: lexing.c caml/fail.h caml/misc.h caml/config.h \
caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
- caml/fail.h caml/md5.h caml/io.h caml/memory.h caml/gc.h \
- caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
- caml/reverse.h
-memory.pic.o: memory.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/fail.h caml/freelist.h caml/gc.h \
- caml/gc_ctrl.h caml/major_gc.h caml/memory.h caml/minor_gc.h \
- caml/signals.h
-meta.pic.o: meta.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/fix_code.h caml/interp.h \
- caml/intext.h caml/io.h caml/major_gc.h caml/freelist.h caml/memory.h \
- caml/gc.h caml/minor_gc.h caml/address_class.h caml/prims.h \
- caml/stacks.h
-minor_gc.pic.o: minor_gc.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/stacks.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
+ caml/minor_gc.h caml/address_class.h
+main.pic.o: main.c caml/misc.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/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/misc.h caml/config.h caml/../../config/m.h \
+ caml/../../config/s.h caml/mlvalues.h caml/fail.h caml/md5.h caml/io.h \
+ caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
+ caml/minor_gc.h caml/address_class.h caml/reverse.h
+memory.pic.o: memory.c caml/address_class.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/misc.h \
+ caml/mlvalues.h caml/fail.h caml/freelist.h caml/gc.h caml/gc_ctrl.h \
+ caml/major_gc.h caml/memory.h caml/minor_gc.h caml/signals.h
+meta.pic.o: meta.c caml/alloc.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
+ caml/fail.h caml/fix_code.h caml/interp.h caml/intext.h caml/io.h \
+ caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \
+ caml/minor_gc.h caml/address_class.h caml/prims.h caml/stacks.h
+minor_gc.pic.o: minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/misc.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
misc.pic.o: misc.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
- caml/compatibility.h caml/misc.h caml/memory.h caml/gc.h \
+ caml/misc.h caml/memory.h caml/gc.h caml/mlvalues.h caml/major_gc.h \
+ caml/freelist.h caml/minor_gc.h caml/address_class.h caml/osdeps.h \
+ caml/version.h
+obj.pic.o: obj.c caml/alloc.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/spacetime.h
+parsing.pic.o: parsing.c caml/config.h caml/../../config/m.h \
+ caml/../../config/s.h caml/mlvalues.h caml/misc.h caml/memory.h \
+ caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
+ caml/address_class.h caml/alloc.h
+prims.pic.o: prims.c caml/mlvalues.h caml/config.h caml/../../config/m.h \
+ caml/../../config/s.h caml/misc.h caml/prims.h
+printexc.pic.o: printexc.c caml/backtrace.h caml/mlvalues.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/exec.h \
+ caml/callback.h caml/debugger.h caml/fail.h caml/printexc.h
+roots.pic.o: roots.c caml/finalise.h caml/roots.h caml/misc.h caml/config.h \
+ caml/../../config/m.h caml/../../config/s.h caml/memory.h caml/gc.h \
caml/mlvalues.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
- caml/address_class.h caml/version.h
-obj.pic.o: obj.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \
+ caml/address_class.h caml/globroots.h caml/stacks.h
+signals.pic.o: signals.c caml/alloc.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 \
- 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 \
- caml/minor_gc.h caml/address_class.h caml/alloc.h
-prims.pic.o: prims.c caml/mlvalues.h caml/compatibility.h caml/config.h \
- caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/prims.h
-printexc.pic.o: printexc.c caml/backtrace.h caml/mlvalues.h \
- caml/compatibility.h caml/config.h caml/../../config/m.h \
- caml/../../config/s.h caml/misc.h caml/exec.h caml/callback.h \
- caml/debugger.h caml/fail.h caml/printexc.h
-roots.pic.o: roots.c caml/finalise.h caml/roots.h caml/misc.h \
- caml/compatibility.h caml/config.h caml/../../config/m.h \
- caml/../../config/s.h caml/memory.h caml/gc.h caml/mlvalues.h \
- caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
- caml/globroots.h caml/stacks.h
-signals.pic.o: signals.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/callback.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/roots.h caml/signals.h caml/signals_machdep.h caml/sys.h
+ caml/callback.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/roots.h \
+ caml/signals.h caml/signals_machdep.h caml/sys.h
signals_byt.pic.o: signals_byt.c caml/config.h caml/../../config/m.h \
- caml/../../config/s.h caml/compatibility.h caml/memory.h caml/gc.h \
- caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \
- caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \
+ caml/../../config/s.h caml/memory.h caml/gc.h caml/mlvalues.h \
+ caml/misc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
+ caml/address_class.h caml/osdeps.h caml/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
+spacetime.pic.o: spacetime.c caml/fail.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 \
- caml/freelist.h caml/minor_gc.h caml/address_class.h
+ caml/../../config/s.h caml/fail.h caml/misc.h caml/mlvalues.h \
+ caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
+ caml/minor_gc.h caml/address_class.h
startup.pic.o: startup.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/backtrace.h caml/exec.h caml/callback.h \
- caml/custom.h caml/debugger.h caml/dynlink.h caml/fail.h \
- caml/fix_code.h caml/freelist.h caml/gc_ctrl.h caml/instrtrace.h \
- caml/interp.h caml/intext.h caml/io.h caml/memory.h caml/gc.h \
- caml/major_gc.h caml/minor_gc.h caml/address_class.h caml/osdeps.h \
- caml/prims.h caml/printexc.h caml/reverse.h caml/signals.h \
- caml/stacks.h caml/sys.h caml/startup.h caml/startup_aux.h \
- caml/version.h
+ caml/../../config/s.h caml/alloc.h caml/misc.h caml/mlvalues.h \
+ caml/backtrace.h caml/exec.h caml/callback.h caml/custom.h \
+ caml/debugger.h caml/dynlink.h caml/fail.h caml/fix_code.h \
+ caml/freelist.h caml/gc_ctrl.h caml/instrtrace.h caml/interp.h \
+ caml/intext.h caml/io.h caml/memory.h caml/gc.h caml/major_gc.h \
+ caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/prims.h \
+ caml/printexc.h caml/reverse.h caml/signals.h caml/stacks.h caml/sys.h \
+ caml/startup.h caml/startup_aux.h caml/version.h
startup_aux.pic.o: startup_aux.c caml/backtrace.h caml/mlvalues.h \
- caml/compatibility.h caml/config.h caml/../../config/m.h \
- caml/../../config/s.h caml/misc.h caml/exec.h caml/memory.h caml/gc.h \
- caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
- caml/startup_aux.h
-str.pic.o: str.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/config.h caml/../../config/m.h caml/../../config/s.h caml/misc.h \
+ caml/exec.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
+ caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/startup_aux.h
+str.pic.o: str.c caml/alloc.h caml/misc.h caml/config.h caml/../../config/m.h \
+ caml/../../config/s.h caml/mlvalues.h caml/fail.h
sys.pic.o: sys.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/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/version.h
+ caml/alloc.h caml/misc.h caml/mlvalues.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/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
+ caml/../../config/s.h caml/alloc.h caml/misc.h caml/mlvalues.h \
+ caml/fail.h caml/io.h
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/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 \
- caml/memory.h caml/gc.h caml/minor_gc.h caml/address_class.h \
- caml/weak.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/io.h
+weak.pic.o: weak.c caml/alloc.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 caml/memory.h caml/gc.h \
+ caml/minor_gc.h caml/address_class.h caml/weak.h
#* *
#**************************************************************************
-include Makefile.common
+include ../config/Makefile
-CFLAGS=-DCAML_NAME_SPACE $(BYTECCCOMPOPTS) $(IFLEXDIR)
-DFLAGS=-DCAML_NAME_SPACE -g -DDEBUG $(BYTECCCOMPOPTS) $(IFLEXDIR)
-IFLAGS=$(CFLAGS) -DCAML_INSTR
-
-OBJS=$(COMMONOBJS) $(UNIX_OR_WIN32).o main.o
-DOBJS=$(OBJS:.o=.d.o) instrtrace.d.o
-IOBJS=$(OBJS:.o=.i.o)
-PICOBJS=$(OBJS:.o=.pic.o)
-
-all:: all-$(SHARED)
-
-ocamlrun$(EXE): libcamlrun.a prims.o
- $(MKEXE) $(BYTECCLINKOPTS) -o ocamlrun$(EXE) \
- prims.o libcamlrun.a $(BYTECCLIBS)
-
-ocamlrund$(EXE): libcamlrund.a prims.o
- $(MKEXE) $(MKEXEDEBUGFLAG) $(BYTECCLINKOPTS) -o ocamlrund$(EXE) \
- prims.o libcamlrund.a $(BYTECCLIBS)
-
-ocamlruni$(EXE): prims.o libcamlruni.a
- $(MKEXE) $(BYTECCLINKOPTS) -o $@ $^ $(BYTECCLIBS)
-
-libcamlrun.a: $(OBJS)
- $(ARCMD) rc libcamlrun.a $(OBJS)
- $(RANLIB) libcamlrun.a
+INSTALL_BINDIR=$(DESTDIR)$(BINDIR)
+INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
-libcamlrund.a: $(DOBJS)
- $(ARCMD) rc libcamlrund.a $(DOBJS)
- $(RANLIB) libcamlrund.a
+# The PROGRAMS (resp. LIBRARIES) variable list the files to build and
+# install as programs in $(INSTALL_BINDIR) (resp. libraries in
+# $(INSTALL_LIBDIR))
-libcamlruni.a: $(IOBJS)
- $(ARCMD) rc $@ $^
- $(RANLIB) $@
+PROGRAMS = ocamlrun$(EXE)
+LIBRARIES = ld.conf libcamlrun.$(A)
-all-noshared:
-.PHONY: all-noshared
+ifeq "$(RUNTIMED)" "true"
+PROGRAMS += ocamlrund$(EXE)
+LIBRARIES += libcamlrund.$(A)
+endif
-all-shared: libcamlrun_pic.a libcamlrun_shared.so
-.PHONY: all-shared
+ifeq "$(RUNTIMEI)" "true"
+PROGRAMS += ocamlruni$(EXE)
+LIBRARIES += libcamlruni.$(A)
+endif
-libcamlrun_pic.a: $(PICOBJS)
- $(ARCMD) rc libcamlrun_pic.a $(PICOBJS)
- $(RANLIB) libcamlrun_pic.a
+ifeq "$(UNIX_OR_WIN32)" "unix"
+ifeq "$(SUPPORTS_SHARED_LIBRARIES)" "true"
+LIBRARIES += libcamlrun_pic.$(A) libcamlrun_shared.$(SO)
+endif
+endif
-libcamlrun_shared.so: $(PICOBJS)
- $(MKDLL) -o libcamlrun_shared.so $(PICOBJS) $(BYTECCLIBS)
+CC=$(BYTECC)
-install:: install-$(SHARED)
+ifdef BOOTSTRAPPING_FLEXLINK
+CFLAGS=-DBOOTSTRAPPING_FLEXLINK
+else
+CFLAGS=
+endif
-install-noshared:
-.PHONY: install-noshared
+# On Windows, OCAML_STDLIB_DIR needs to be defined dynamically
-install-shared:
- cp libcamlrun_shared.so "$(INSTALL_LIBDIR)/libcamlrun_shared.so"
- cp libcamlrun_pic.a "$(INSTALL_LIBDIR)/libcamlrun_pic.a"
- cd "$(INSTALL_LIBDIR)"; $(RANLIB) libcamlrun_pic.a
-.PHONY: install-shared
+ifeq "$(UNIX_OR_WIN32)" "win32"
+CFLAGS += -DOCAML_STDLIB_DIR='"$(LIBDIR)"'
+endif
-clean::
- rm -f libcamlrun_shared.so libcamlrun_pic.a
-
-%.d.o: %.c
- $(CC) -c $(DFLAGS) $< -o $@
-
-%.i.o: %.c
- $(CC) -c $(IFLAGS) -o $@ $<
-
-%.pic.o: %.c
- $(CC) -c $(CFLAGS) $(SHAREDCCCOMPOPTS) $< -o $@
+CFLAGS += $(IFLEXDIR) $(BYTECCCOMPOPTS)
+DFLAGS=$(CFLAGS) -DDEBUG
+IFLAGS=$(CFLAGS) -DCAML_INSTR
+PICFLAGS=$(CFLAGS) $(SHAREDCCCOMPOPTS)
+
+ifneq "$(CCOMPTYPE)" "msvc"
+DFLAGS += -g
+endif
+
+ifeq "$(CCOMPTYPE)" "msvc"
+OUTPUTOBJ=-Fo
+else
+OUTPUTOBJ=-o
+endif
+DBGO=d.$(O)
+
+ifeq "$(UNIX_OR_WIN32)" "win32"
+LIBS = $(call SYSLIB,ws2_32) $(EXTRALIBS)
+ifdef BOOTSTRAPPING_FLEXLINK
+MAKE_OCAMLRUN=$(MKEXE_BOOT)
+else
+MAKE_OCAMLRUN = $(MKEXE) -o $(1) $(2)
+endif
+else
+LIBS = $(BYTECCLIBS)
+MAKE_OCAMLRUN = $(MKEXE) $(BYTECCLINKOPTS) -o $(1) $(2)
+endif
+
+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 spacetime.c afl.c
+
+OBJS=$(addsuffix .$(O), \
+ interp misc stacks fix_code startup_aux startup \
+ freelist major_gc minor_gc memory alloc roots globroots \
+ fail signals signals_byt printexc backtrace_prim backtrace \
+ compare ints floats str array io extern intern \
+ hash sys meta parsing gc_ctrl terminfo md5 obj \
+ lexing callback debugger weak compact finalise custom \
+ dynlink spacetime afl $(UNIX_OR_WIN32) main)
+
+DOBJS=$(OBJS:.$(O)=.$(DBGO)) instrtrace.$(DBGO)
+IOBJS=$(OBJS:.$(O)=.i.$(O))
+PICOBJS=$(OBJS:.$(O)=.pic.$(O))
+
+.PHONY: all
+all: $(LIBRARIES) $(PROGRAMS)
+
+ld.conf: ../config/Makefile
+ echo "$(STUBLIBDIR)" > $@
+ echo "$(LIBDIR)" >> $@
+
+.PHONY: install
+install:
+ cp $(PROGRAMS) "$(INSTALL_BINDIR)"
+ cp $(LIBRARIES) "$(INSTALL_LIBDIR)"
+ mkdir -p "$(INSTALL_LIBDIR)/caml"
+ for i in caml/*.h; do \
+ sed -f ../tools/cleanup-header $$i \
+ > "$(INSTALL_LIBDIR)/$$i"; \
+ done
+
+# If primitives contain duplicated lines (e.g. because the code is defined
+# like
+# #ifdef X
+# CAMLprim value caml_foo() ...
+# #else
+# CAMLprim value caml_foo() ...
+# end), horrible things will happen (duplicated entries in Runtimedef ->
+# double registration in Symtable -> empty entry in the PRIM table ->
+# the bytecode interpreter is confused).
+# We sort the primitive file and remove duplicates to avoid this problem.
+
+# Warning: we use "sort | uniq" instead of "sort -u" because in the MSVC
+# port, the "sort" program in the path is Microsoft's and not cygwin's
+
+# Warning: POSIX sort is locale dependent, that's why we set LC_ALL explicitly.
+# Sort is unstable for "is_directory" and "isatty"
+# see http://pubs.opengroup.org/onlinepubs/9699919799/utilities/sort.html:
+# "using sort to process pathnames, it is recommended that LC_ALL .. set to C"
+
+
+primitives : $(PRIMS)
+ sed -n -e "s/CAMLprim value \([a-z0-9_][a-z0-9_]*\).*/\1/p" $(PRIMS) \
+ | LC_ALL=C sort | uniq > primitives
+
+prims.c : primitives
+ (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[] = {'; \
+ sed -e 's/.*/ &,/' primitives; \
+ echo ' 0 };'; \
+ echo 'char * caml_names_of_builtin_cprim[] = {'; \
+ sed -e 's/.*/ "&",/' primitives; \
+ echo ' 0 };') > prims.c
+
+caml/opnames.h : caml/instruct.h
+ sed -e '/\/\*/d' \
+ -e '/^#/d' \
+ -e 's/enum /char * names_of_/' \
+ -e 's/{$$/[] = {/' \
+ -e 's/\([[:upper:]][[:upper:]_0-9]*\)/"\1"/g' caml/instruct.h \
+ > caml/opnames.h
+
+# caml/jumptbl.h is required only if you have GCC 2.0 or later
+caml/jumptbl.h : caml/instruct.h
+ sed -n -e '/^ /s/ \([A-Z]\)/ \&\&lbl_\1/gp' \
+ -e '/^}/q' caml/instruct.h > caml/jumptbl.h
+
+caml/version.h : ../VERSION ../tools/make-version-header.sh
+ ../tools/make-version-header.sh ../VERSION > caml/version.h
+
+.PHONY: clean
+clean:
+ rm -f $(LIBRARIES) $(PROGRAMS) *.$(O) *.$(A) *.$(SO)
+ rm -f primitives prims.c caml/opnames.h caml/jumptbl.h
+ rm -f caml/version.h
+
+ocamlrun$(EXE): prims.$(O) libcamlrun.$(A)
+ $(call MAKE_OCAMLRUN,$@,$^ $(LIBS))
+
+libcamlrun.$(A): $(OBJS)
+ $(call MKLIB,$@, $^)
+
+ocamlrund$(EXE): prims.$(O) libcamlrund.$(A)
+ $(MKEXE) $(MKEXEDEBUGFLAG) $(BYTECCLINKOPTS) -o $@ $^ $(LIBS)
+
+libcamlrund.$(A): $(DOBJS)
+ $(call MKLIB,$@, $^)
+
+ocamlruni$(EXE): prims.$(O) libcamlruni.$(A)
+ $(MKEXE) $(BYTECCLINKOPTS) -o $@ $^ $(LIBS)
+
+libcamlruni.$(A): $(IOBJS)
+ $(call MKLIB,$@, $^)
+
+libcamlrun_pic.$(A): $(PICOBJS)
+ $(call MKLIB,$@, $^)
+
+libcamlrun_shared.$(SO): $(PICOBJS)
+ $(MKDLL) -o $@ $^ $(BYTECCLIBS)
+
+%.$(O): %.c
+ $(CC) $(CFLAGS) -c $<
+
+%.$(DBGO): %.c
+ $(CC) $(DFLAGS) -c $(OUTPUTOBJ)$@ $<
+
+%.i.$(O): %.c
+ $(CC) $(IFLAGS) -c $(OUTPUTOBJ)$@ $<
+
+%.pic.$(O): %.c
+ $(CC) $(PICFLAGS) -c $(OUTPUTOBJ)$@ $<
+
+ifneq "$(TOOLCHAIN)" "msvc"
+.PHONY: depend
depend : prims.c caml/opnames.h caml/jumptbl.h caml/version.h
-$(CC) -MM $(BYTECCCOMPOPTS) *.c > .depend
-$(CC) -MM $(BYTECCCOMPOPTS) -DDEBUG *.c | sed -e 's/\.o/.d.o/' \
-$(CC) -MM $(BYTECCCOMPOPTS) -DCAML_INSTR *.c | sed -e 's/\.o/.i.o/' \
>> .depend
-$(CC) -MM $(BYTECCCOMPOPTS) *.c | sed -e 's/\.o/.pic.o/' >> .depend
-.PHONY: depend
-
+endif
+
+ifeq "$(UNIX_OR_WIN32)" "win32"
+.depend.nt: .depend
+ rm -f .depend.win32
+ echo "win32.o: win32.c caml/fail.h caml/compatibility.h \\"\
+ >> .depend.win32
+ echo " caml/misc.h caml/config.h ../config/m.h ../config/s.h \\"\
+ >> .depend.win32
+ echo " caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h \\"\
+ >> .depend.win32
+ echo " caml/freelist.h caml/minor_gc.h caml/osdeps.h caml/signals.h"\
+ >> .depend.win32
+ cat .depend >> .depend.win32
+ 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
+
+include .depend.nt
+
+else
include .depend
+endif
+++ /dev/null
-#**************************************************************************
-#* *
-#* 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 ../config/Makefile
-CAMLRUN ?= ../boot/ocamlrun
-CAMLYACC ?= ../boot/ocamlyacc
-
-CC=$(BYTECC)
-
-COMMONOBJS=\
- interp.o misc.o stacks.o fix_code.o startup_aux.o startup.o \
- freelist.o major_gc.o minor_gc.o memory.o alloc.o roots.o globroots.o \
- fail.o signals.o signals_byt.o printexc.o backtrace_prim.o backtrace.o \
- 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 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 spacetime.c
-
-all:: ocamlrun$(EXE) ld.conf libcamlrun.$(A) all-$(RUNTIMED) primitives
-.PHONY: all
-
-all-noruntimed:
-.PHONY: all-noruntimed
-
-all-runtimed: ocamlrund$(EXE) libcamlrund.$(A)
-.PHONY: all-runtimed
-
-ifeq "$(RUNTIMEI)" "true"
-all:: ocamlruni$(EXE) libcamlruni.$(A)
-endif
-
-ld.conf: ../config/Makefile
- echo "$(STUBLIBDIR)" > ld.conf
- echo "$(LIBDIR)" >> ld.conf
-
-# Installation
-
-INSTALL_BINDIR=$(DESTDIR)$(BINDIR)
-INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
-
-
-install::
- cp $(CAMLRUN)$(EXE) "$(INSTALL_BINDIR)/ocamlrun$(EXE)"
- cp libcamlrun.$(A) "$(INSTALL_LIBDIR)/libcamlrun.$(A)"
- cd "$(INSTALL_LIBDIR)"; $(RANLIB) libcamlrun.$(A)
- if test -d "$(INSTALL_LIBDIR)/caml"; then : ; \
- else mkdir "$(INSTALL_LIBDIR)/caml"; fi
- 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
-
-install:: install-$(RUNTIMED)
-
-install-noruntimed:
-.PHONY: install-noruntimed
-
-# TODO: when cross-compiling, do not install ocamlrund
-# it doesn't hurt to install it, but it's useless and might be confusing
-# because it's an executable for the target machine, while we're installing
-# binaries for the host.
-install-runtimed:
- cp ocamlrund$(EXE) "$(INSTALL_BINDIR)/ocamlrund$(EXE)"
- cp libcamlrund.$(A) "$(INSTALL_LIBDIR)/libcamlrund.$(A)"
-.PHONY: install-runtimed
-
-ifeq "$(RUNTIMEI)" "true"
-install::
- cp ocamlruni$(EXE) $(INSTALL_BINDIR)/ocamlruni$(EXE)
- cp libcamlruni.$(A) $(INSTALL_LIBDIR)/libcamlruni.$(A)
-endif
-
-# If primitives contain duplicated lines (e.g. because the code is defined
-# like
-# #ifdef X
-# CAMLprim value caml_foo() ...
-# #else
-# CAMLprim value caml_foo() ...
-# end), horrible things will happen (duplicated entries in Runtimedef ->
-# double registration in Symtable -> empty entry in the PRIM table ->
-# the bytecode interpreter is confused).
-# We sort the primitive file and remove duplicates to avoid this problem.
-
-# Warning: we use "sort | uniq" instead of "sort -u" because in the MSVC
-# port, the "sort" program in the path is Microsoft's and not cygwin's
-
-primitives : $(PRIMS)
- sed -n -e "s/CAMLprim value \([a-z0-9_][a-z0-9_]*\).*/\1/p" $(PRIMS) \
- | sort | uniq > primitives
-
-prims.c : primitives
- (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[] = {'; \
- sed -e 's/.*/ &,/' primitives; \
- echo ' 0 };'; \
- echo 'char * caml_names_of_builtin_cprim[] = {'; \
- sed -e 's/.*/ "&",/' primitives; \
- echo ' 0 };') > prims.c
-
-caml/opnames.h : caml/instruct.h
- sed -e '/\/\*/d' \
- -e '/^#/d' \
- -e 's/enum /char * names_of_/' \
- -e 's/{$$/[] = {/' \
- -e 's/\([[:upper:]][[:upper:]_0-9]*\)/"\1"/g' caml/instruct.h \
- > caml/opnames.h
-
-# caml/jumptbl.h is required only if you have GCC 2.0 or later
-caml/jumptbl.h : caml/instruct.h
- sed -n -e '/^ /s/ \([A-Z]\)/ \&\&lbl_\1/gp' \
- -e '/^}/q' caml/instruct.h > caml/jumptbl.h
-
-caml/version.h : ../VERSION ../tools/make-version-header.sh
- ../tools/make-version-header.sh ../VERSION > caml/version.h
-
-clean ::
- rm -f ocamlrun$(EXE) ocamlrund$(EXE) *.$(O) *.$(A) *.$(SO)
- rm -f primitives prims.c caml/opnames.h caml/jumptbl.h ld.conf
- rm -f caml/version.h
-.PHONY: clean
#* *
#**************************************************************************
-include Makefile.common
-
-CFLAGS=-DOCAML_STDLIB_DIR='"$(LIBDIR)"' $(IFLEXDIR)
-DFLAGS=$(CFLAGS) -DDEBUG
-
-ifdef BOOTSTRAPPING_FLEXLINK
-MAKE_OCAMLRUN=$(MKEXE_BOOT)
-CFLAGS:=-DBOOTSTRAPPING_FLEXLINK $(CFLAGS)
-else
-MAKE_OCAMLRUN=$(MKEXE) -o $(1) $(2)
-endif
-
-DBGO=d.$(O)
-OBJS=$(COMMONOBJS:.o=.$(O)) win32.$(O) main.$(O)
-DOBJS=$(OBJS:.$(O)=.$(DBGO)) instrtrace.$(DBGO)
-
-ocamlrun$(EXE): libcamlrun.$(A) prims.$(O)
- $(call MAKE_OCAMLRUN,ocamlrun$(EXE),prims.$(O) libcamlrun.$(A) \
- $(call SYSLIB,ws2_32) $(EXTRALIBS))
-
-ocamlrund$(EXE): libcamlrund.$(A) prims.$(O) main.$(O)
- $(MKEXE) -o ocamlrund$(EXE) prims.$(O) \
- $(call SYSLIB,ws2_32) $(EXTRALIBS) libcamlrund.$(A)
-
-libcamlrun.$(A): $(OBJS)
- $(call MKLIB,libcamlrun.$(A),$(OBJS))
-
-libcamlrund.$(A): $(DOBJS)
- $(call MKLIB,libcamlrund.$(A),$(DOBJS))
-
-%.$(O): %.c
- $(CC) $(CFLAGS) $(BYTECCCOMPOPTS) -c $<
-
-# It is imperative that there is no space after $(NAME_OBJ_FLAG)
-%.$(DBGO): %.c
- $(CC) $(DFLAGS) $(BYTECCDBGCOMPOPTS) -c $(NAME_OBJ_FLAG)$@ $<
-
-.depend.nt: .depend
- rm -f .depend.win32
- echo "win32.o: win32.c caml/fail.h caml/compatibility.h \\"\
- >> .depend.win32
- echo " caml/misc.h caml/config.h ../config/m.h ../config/s.h \\"\
- >> .depend.win32
- echo " caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h \\"\
- >> .depend.win32
- echo " caml/freelist.h caml/minor_gc.h caml/osdeps.h caml/signals.h"\
- >> .depend.win32
- cat .depend >> .depend.win32
- 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
-
-include .depend.nt
+include Makefile
--- /dev/null
+/**************************************************************************/
+/* */
+/* OCaml */
+/* */
+/* Stephen Dolan, University of Cambridge */
+/* */
+/* Copyright 2016 Stephen Dolan. */
+/* */
+/* All rights reserved. This file is distributed under the terms of */
+/* the GNU Lesser General Public License version 2.1, with the */
+/* special exception on linking described in the file LICENSE. */
+/* */
+/**************************************************************************/
+
+/* Runtime support for afl-fuzz */
+
+/* Android's libc does not implement System V shared memory. */
+#if defined(_WIN32) || defined(__ANDROID__)
+
+#include "caml/mlvalues.h"
+
+CAMLprim value caml_setup_afl (value unit)
+{
+ return Val_unit;
+}
+
+CAMLprim value caml_reset_afl_instrumentation(value unused)
+{
+ return Val_unit;
+}
+
+#else
+
+#include <unistd.h>
+#include <sys/types.h>
+#include <signal.h>
+#include <sys/shm.h>
+#include <sys/wait.h>
+#include <stdio.h>
+#include <string.h>
+
+#define CAML_INTERNALS
+#include "caml/misc.h"
+#include "caml/mlvalues.h"
+#include "caml/osdeps.h"
+
+static int afl_initialised = 0;
+
+/* afl uses abnormal termination (SIGABRT) to check whether
+ to count a testcase as "crashing" */
+extern int caml_abort_on_uncaught_exn;
+
+/* Values used by the instrumentation logic (see cmmgen.ml) */
+static unsigned char afl_area_initial[1 << 16];
+unsigned char* caml_afl_area_ptr = afl_area_initial;
+uintnat caml_afl_prev_loc;
+
+/* File descriptors used to synchronise with afl-fuzz */
+#define FORKSRV_FD_READ 198
+#define FORKSRV_FD_WRITE 199
+
+static void afl_write(uint32_t msg)
+{
+ if (write(FORKSRV_FD_WRITE, &msg, 4) != 4)
+ caml_fatal_error("writing to afl-fuzz");
+}
+
+static uint32_t afl_read()
+{
+ uint32_t msg;
+ if (read(FORKSRV_FD_READ, &msg, 4) != 4)
+ caml_fatal_error("reading from afl-fuzz");
+ return msg;
+}
+
+CAMLprim value caml_setup_afl(value unit)
+{
+ if (afl_initialised) return Val_unit;
+ afl_initialised = 1;
+
+ char* shm_id_str = caml_secure_getenv("__AFL_SHM_ID");
+ if (shm_id_str == NULL) {
+ /* Not running under afl-fuzz, continue as normal */
+ return Val_unit;
+ }
+
+ /* if afl-fuzz is attached, we want it to know about uncaught exceptions */
+ caml_abort_on_uncaught_exn = 1;
+
+ char* shm_id_end;
+ long int shm_id = strtol(shm_id_str, &shm_id_end, 10);
+ if (!(*shm_id_str != '\0' && *shm_id_end == '\0'))
+ caml_fatal_error("afl-fuzz: bad shm id");
+
+ caml_afl_area_ptr = shmat((int)shm_id, NULL, 0);
+ if (caml_afl_area_ptr == (void*)-1)
+ caml_fatal_error("afl-fuzz: could not attach shm area");
+
+ /* poke the bitmap so that afl-fuzz knows we exist, even if the
+ application has sparse instrumentation */
+ caml_afl_area_ptr[0] = 1;
+
+ /* synchronise with afl-fuzz */
+ uint32_t startup_msg = 0;
+ if (write(FORKSRV_FD_WRITE, &startup_msg, 4) != 4) {
+ /* initial write failed, so assume we're not meant to fork.
+ afl-tmin uses this mode. */
+ return Val_unit;
+ }
+ afl_read();
+
+ while (1) {
+ int child_pid = fork();
+ if (child_pid < 0) caml_fatal_error("afl-fuzz: could not fork");
+ else if (child_pid == 0) {
+ /* Run the program */
+ close(FORKSRV_FD_READ);
+ close(FORKSRV_FD_WRITE);
+ return Val_unit;
+ }
+
+ /* As long as the child keeps raising SIGSTOP, we re-use the same process */
+ while (1) {
+ afl_write((uint32_t)child_pid);
+
+ int status;
+ /* WUNTRACED means wait until termination or SIGSTOP */
+ if (waitpid(child_pid, &status, WUNTRACED) < 0)
+ caml_fatal_error("afl-fuzz: waitpid failed");
+
+ afl_write((uint32_t)status);
+
+ uint32_t was_killed = afl_read();
+ if (WIFSTOPPED(status)) {
+ /* child stopped, waiting for another test case */
+ if (was_killed) {
+ /* we saw the child stop, but since then afl-fuzz killed it.
+ we should wait for it before forking another child */
+ if (waitpid(child_pid, &status, 0) < 0)
+ caml_fatal_error("afl-fuzz: waitpid failed");
+ break;
+ } else {
+ kill(child_pid, SIGCONT);
+ }
+ } else {
+ /* child died */
+ break;
+ }
+ }
+ }
+}
+
+CAMLprim value caml_reset_afl_instrumentation(value full)
+{
+ if (full != Val_int(0)) {
+ memset(caml_afl_area_ptr, 0, sizeof(afl_area_initial));
+ }
+ caml_afl_prev_loc = 0;
+ return Val_unit;
+}
+
+#endif /* _WIN32 */
{
mlsize_t wosize = len * Double_wosize;
value result;
+ /* For consistency with [caml_make_vect], which can't tell whether it should
+ create a float array or not when the size is zero, the tag is set to
+ zero when the size is zero. */
if (wosize == 0)
return Atom(0);
else if (wosize <= Max_young_wosize){
#include "caml/misc.h"
#include "caml/mlvalues.h"
#include "caml/signals.h"
-#include "spacetime.h"
+/* Why is caml/spacetime.h included conditionnally sometimes and not here ? */
+#include "caml/spacetime.h"
static const mlsize_t mlsize_t_max = -1;
caml_backtrace_active = flag;
caml_backtrace_pos = 0;
caml_backtrace_last_exn = Val_unit;
- /* Note: lazy initialization of caml_backtrace_buffer in
- caml_stash_backtrace to simplify the interface with the thread
- libraries */
+ /* Note: We do lazy initialization of caml_backtrace_buffer when
+ needed in order to simplify the interface with the thread
+ library (thread creation doesn't need to allocate
+ caml_backtrace_buffer). So we don't have to allocate it here.
+ */
}
return Val_unit;
}
CAMLreturn(res);
}
+/* Copy back a backtrace and exception to the global state.
+ This function should be used only with Printexc.raw_backtrace */
+/* noalloc (caml value): so no CAMLparam* CAMLreturn* */
+CAMLprim value caml_restore_raw_backtrace(value exn, value backtrace)
+{
+ intnat i;
+ mlsize_t bt_size;
+
+ caml_backtrace_last_exn = exn;
+
+ bt_size = Wosize_val(backtrace);
+ if(bt_size > BACKTRACE_BUFFER_SIZE){
+ bt_size = BACKTRACE_BUFFER_SIZE;
+ }
+
+ /* We don't allocate if the backtrace is empty (no -g or backtrace
+ not activated) */
+ if(bt_size == 0){
+ caml_backtrace_pos = 0;
+ return Val_unit;
+ }
+
+ /* Allocate if needed and copy the backtrace buffer */
+ if (caml_backtrace_buffer == NULL && caml_alloc_backtrace_buffer() == -1){
+ return Val_unit;
+ }
+
+ caml_backtrace_pos = bt_size;
+ for(i=0; i < caml_backtrace_pos; i++){
+ caml_backtrace_buffer[i] = Backtrace_slot_val(Field(backtrace, i));
+ }
+
+ return Val_unit;
+}
+
#define Val_debuginfo(bslot) (Val_long((uintnat)(bslot)>>1))
#define Debuginfo_val(vslot) ((debuginfo)(Long_val(vslot) << 1))
CAMLreturn(Val_unit);
}
+int caml_alloc_backtrace_buffer(void){
+ Assert(caml_backtrace_pos == 0);
+ caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t));
+ if (caml_backtrace_buffer == NULL) return -1;
+ return 0;
+}
+
/* Store the return addresses contained in the given stack fragment
into the backtrace array */
caml_backtrace_last_exn = exn;
}
- if (caml_backtrace_buffer == NULL) {
- Assert(caml_backtrace_pos == 0);
- caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t));
- if (caml_backtrace_buffer == NULL) return;
- }
+ if (caml_backtrace_buffer == NULL && caml_alloc_backtrace_buffer() == -1)
+ return;
if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return;
/* testing the code region is needed: PR#1554 */
#define Val_backtrace_slot(bslot) (Val_long(((uintnat)(bslot))>>1))
#define Backtrace_slot_val(vslot) ((backtrace_slot)(Long_val(vslot) << 1))
+/* Allocate the caml_backtrace_buffer. Returns 0 on success, -1 otherwise */
+int caml_alloc_backtrace_buffer(void);
+
#define BACKTRACE_BUFFER_SIZE 1024
/* Besides decoding backtrace info, [backtrace_prim] has two other
CAMLextern void caml_main (char ** argv);
CAMLextern void caml_startup (char ** argv);
+CAMLextern value caml_startup_exn (char ** argv);
CAMLextern int caml_callback_depth;
CAMLnoreturn_end;
CAMLnoreturn_start
-CAMLextern void caml_failwith (char const *)
+CAMLextern void caml_failwith (char const *msg)
CAMLnoreturn_end;
CAMLnoreturn_start
-CAMLextern void caml_invalid_argument (char const *)
+CAMLextern void caml_failwith_value (value msg)
+CAMLnoreturn_end;
+
+CAMLnoreturn_start
+CAMLextern void caml_invalid_argument (char const *msg)
+CAMLnoreturn_end;
+
+CAMLnoreturn_start
+CAMLextern void caml_invalid_argument_value (value msg)
CAMLnoreturn_end;
CAMLnoreturn_start
+ (tag_t) (tag))) \
)
-#ifdef WITH_SPACETIME
-struct ext_table;
-extern uintnat caml_spacetime_my_profinfo(struct ext_table**, uintnat);
+#ifdef WITH_PROFINFO
#define Make_header_with_profinfo(wosize, tag, color, profinfo) \
(Make_header(wosize, tag, color) \
| ((((intnat) profinfo) & PROFINFO_MASK) << PROFINFO_SHIFT) \
)
+#else
+#define Make_header_with_profinfo(wosize, tag, color, profinfo) \
+ Make_header(wosize, tag, color)
+#endif
+
+#ifdef WITH_SPACETIME
+struct ext_table;
+extern uintnat caml_spacetime_my_profinfo(struct ext_table**, uintnat);
#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)
CAMLextern value caml_alloc_shr (mlsize_t wosize, tag_t);
-#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+#ifdef WITH_PROFINFO
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);
+ 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
+#endif /* WITH_PROFINFO */
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);
#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_VOID_PRIM_1(code,prim,arg1) \
+ (caml_cplugins_prim == NULL) ? prim(arg1) : \
+ (void)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)
caml_cplugins_prim(code,(intnat) (arg1), (intnat) (arg2),(intnat) (arg3))
#define CAML_SYS_EXIT(retcode) \
- CAML_SYS_PRIM_1(CAML_CPLUGINS_EXIT,exit,retcode)
+ CAML_SYS_VOID_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) \
#define PROFINFO_MASK ((1ull << PROFINFO_WIDTH) - 1ull)
#define Tag_hd(hd) ((tag_t) ((hd) & 0xFF))
-#ifdef WITH_SPACETIME
+#ifdef WITH_PROFINFO
#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
+#endif /* WITH_PROFINFO */
+#if defined(ARCH_SIXTYFOUR) && defined(WITH_PROFINFO)
/* [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 */
+#endif /* ARCH_SIXTYFOUR && WITH_PROFINFO */
#define Hd_val(val) (((header_t *) (val)) [-1]) /* Also an l-value. */
#define Hd_op(op) (Hd_val (op)) /* Also an l-value. */
#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
+#endif /* ARCH_SIXTYFOUR */
#define Wosize_val(val) (Wosize_hd (Hd_val (val)))
#define Wosize_op(op) (Wosize_val (op))
this tag cannot be mistaken for pointers (see caml_obj_truncate).
*/
#define Abstract_tag 251
+#define Data_abstract_val(v) ((void*) Op_val(v))
/* Strings. */
#define String_tag 252
extern int caml_read_directory(char * dirname, struct ext_table * contents);
/* Recover executable name if possible (/proc/sef/exe under Linux,
- GetModuleFileName under Windows). */
-extern int caml_executable_name(char * name, int name_len);
+ GetModuleFileName under Windows). Return NULL on error,
+ string allocated with [caml_stat_alloc] on success. */
+extern char * caml_executable_name(void);
+
+/* Secure version of [getenv]: returns NULL if the process has special
+ privileges (setuid bit, setgid bit, capabilities).
+*/
+extern char *caml_secure_getenv(char const *var);
#endif /* CAML_INTERNALS */
--- /dev/null
+/**************************************************************************/
+/* */
+/* 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
+
+#ifdef NATIVE_CODE
+
+#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
+
+#else
+
+#define Get_my_profinfo_with_cached_backtrace(profinfo, size) \
+ profinfo = (uintnat) 0;
+
+#endif /* NATIVE_CODE */
+
+
+#endif
char *section_table, asize_t section_table_size,
char **argv);
+CAMLextern value caml_startup_code_exn(
+ code_t code, asize_t code_size,
+ char *data, asize_t data_size,
+ char *section_table, asize_t section_table_size,
+ char **argv);
+
enum { FILE_NOT_FOUND = -1, BAD_BYTECODE = -2 };
extern int caml_attempt_open(char **name, struct exec_trailer *trail,
XXX (see [caml_register_global_roots])
XXX Should be able to fix it to only assume 2-byte alignment.
*/
-#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+#ifdef WITH_PROFINFO
#define Make_ehd(s,t,c,p) \
(((s) << 10) | (t) << 2 | (c) | ((p) << PROFINFO_SHIFT))
#else
size_t sz;
tag_t t;
char *newadr;
+#ifdef WITH_PROFINFO
uintnat profinfo;
+#endif
word *infixes = NULL;
while (Ecolor (q) == 0) q = * (word *) q;
sz = Whsize_ehd (q);
t = Tag_ehd (q);
+#ifdef WITH_PROFINFO
profinfo = Profinfo_ehd (q);
-
+#endif
if (t == Infix_tag){
/* Get the original header of this block. */
infixes = p + sz;
#include "caml/config.h"
#include "caml/debugger.h"
#include "caml/misc.h"
+#include "caml/osdeps.h"
int caml_debugger_in_use = 0;
uintnat caml_event_count;
Store_field(marshal_flags, 0, Val_int(1)); /* Marshal.Closures */
Store_field(marshal_flags, 1, Val_emptylist);
- address = getenv("CAML_DEBUG_SOCKET");
+ address = caml_secure_getenv("CAML_DEBUG_SOCKET");
if (address == NULL) return;
dbg_addr = address;
struct stat st;
int ldconf, nread;
- stdlib = getenv("OCAMLLIB");
- if (stdlib == NULL) stdlib = getenv("CAMLLIB");
+ stdlib = caml_secure_getenv("OCAMLLIB");
+ if (stdlib == NULL) stdlib = caml_secure_getenv("CAMLLIB");
if (stdlib == NULL) stdlib = OCAML_STDLIB_DIR;
ldconfname = caml_strconcat(3, stdlib, "/", LD_CONF_NAME);
if (stat(ldconfname, &st) == -1) {
- directories specified in the executable
- directories specified in the file <stdlib>/ld.conf */
tofree1 = caml_decompose_path(&caml_shared_libs_path,
- getenv("CAML_LD_LIBRARY_PATH"));
+ caml_secure_getenv("CAML_LD_LIBRARY_PATH"));
if (lib_path != NULL)
for (p = lib_path; *p != 0; p += strlen(p) + 1)
caml_ext_table_add(&caml_shared_libs_path, p);
if (tag < 16) {
write(PREFIX_SMALL_BLOCK + tag);
} else {
-#if !(defined(NATIVE_CODE) && defined(WITH_SPACETIME))
- writecode32(CODE_BLOCK32, hd);
-#else
+#ifdef WITH_PROFINFO
writecode32(CODE_BLOCK32, Hd_no_profinfo(hd));
+#else
+ writecode32(CODE_BLOCK32, hd);
#endif
}
goto next_item;
write(PREFIX_SMALL_BLOCK + tag + (sz << 4));
} else {
#ifdef ARCH_SIXTYFOUR
-#if !(defined(NATIVE_CODE) && defined(WITH_SPACETIME))
- header_t hd_erased = hd;
-#else
+#ifdef WITH_PROFINFO
header_t hd_erased = Hd_no_profinfo(hd);
+#else
+ header_t hd_erased = hd;
#endif
if (sz > 0x3FFFFF && (extern_flags & COMPAT_32))
extern_failwith("output_value: array cannot be read back on "
CAMLnoreturn;
}
-/* PR#5115: Failure and Invalid_argument can be triggered by
- input_value while reading the initial value of [caml_global_data]. */
-
-CAMLexport void caml_failwith (char const *msg)
+/* PR#5115: Built-in exceptions can be triggered by input_value
+ while reading the initial value of [caml_global_data].
+
+ We check against this issue here in byterun/fail.c instead of
+ byterun/intern.c. Having the check here means that these calls will
+ be slightly slower for all bytecode programs (not just the calls
+ coming from intern). Because intern.c is shared between byterun/
+ and asmrun/, putting checks there would slow do input_value for
+ natively-compiled programs that do not need these checks.
+*/
+static void check_global_data(char const *exception_name)
{
if (caml_global_data == 0) {
- fprintf(stderr, "Fatal error: exception Failure(\"%s\")\n", msg);
+ fprintf(stderr, "Fatal error: exception %s\n", exception_name);
exit(2);
}
- caml_raise_with_string(Field(caml_global_data, FAILURE_EXN), msg);
}
-CAMLexport void caml_invalid_argument (char const *msg)
+static void check_global_data_param(char const *exception_name, char const *msg)
{
if (caml_global_data == 0) {
- fprintf(stderr, "Fatal error: exception Invalid_argument(\"%s\")\n", msg);
+ fprintf(stderr, "Fatal error: exception %s(\"%s\")\n", exception_name, msg);
exit(2);
}
- caml_raise_with_string(Field(caml_global_data, INVALID_EXN), msg);
+}
+
+static inline value caml_get_failwith_tag (char const *msg)
+{
+ check_global_data_param("Failure", msg);
+ return Field(caml_global_data, FAILURE_EXN);
+}
+
+CAMLexport void caml_failwith (char const *msg)
+{
+ caml_raise_with_string(caml_get_failwith_tag(msg), msg);
+}
+
+CAMLexport void caml_failwith_value (value msg)
+{
+ CAMLparam1(msg);
+ value tag = caml_get_failwith_tag(String_val(msg));
+ caml_raise_with_arg(tag, msg);
+ CAMLnoreturn;
+}
+
+static inline value caml_get_invalid_argument_tag (char const *msg)
+{
+ check_global_data_param("Invalid_argument", msg);
+ return Field(caml_global_data, INVALID_EXN);
+}
+
+CAMLexport void caml_invalid_argument (char const *msg)
+{
+ caml_raise_with_string(caml_get_invalid_argument_tag(msg), msg);
+}
+
+CAMLexport void caml_invalid_argument_value (value msg)
+{
+ CAMLparam1(msg);
+ value tag = caml_get_invalid_argument_tag(String_val(msg));
+ caml_raise_with_arg(tag, msg);
+ CAMLnoreturn;
}
CAMLexport void caml_array_bound_error(void)
CAMLexport void caml_raise_out_of_memory(void)
{
+ check_global_data("Out_of_memory");
caml_raise_constant(Field(caml_global_data, OUT_OF_MEMORY_EXN));
}
CAMLexport void caml_raise_stack_overflow(void)
{
+ check_global_data("Stack_overflow");
caml_raise_constant(Field(caml_global_data, STACK_OVERFLOW_EXN));
}
CAMLexport void caml_raise_sys_error(value msg)
{
+ check_global_data_param("Sys_error", String_val(msg));
caml_raise_with_arg(Field(caml_global_data, SYS_ERROR_EXN), msg);
}
CAMLexport void caml_raise_end_of_file(void)
{
+ check_global_data("End_of_file");
caml_raise_constant(Field(caml_global_data, END_OF_FILE_EXN));
}
CAMLexport void caml_raise_zero_divide(void)
{
+ check_global_data("Division_by_zero");
caml_raise_constant(Field(caml_global_data, ZERO_DIVIDE_EXN));
}
CAMLexport void caml_raise_not_found(void)
{
+ check_global_data("Not_found");
caml_raise_constant(Field(caml_global_data, NOT_FOUND_EXN));
}
CAMLexport void caml_raise_sys_blocked_io(void)
{
+ check_global_data("Sys_blocked_io");
caml_raise_constant(Field(caml_global_data, SYS_BLOCKED_IO));
}
int caml_is_special_exception(value exn) {
+ /* this function is only used in caml_format_exception to produce
+ a more readable textual representation of some exceptions. It is
+ better to fall back to the general, less readable representation
+ than to abort with a fatal error as above. */
+ if (caml_global_data == 0) return 0;
return exn == Field(caml_global_data, MATCH_FAILURE_EXN)
|| exn == Field(caml_global_data, ASSERT_FAILURE_EXN)
|| exn == Field(caml_global_data, UNDEFINED_RECURSIVE_MODULE_EXN);
#include "caml/roots.h"
#include "caml/signals.h"
#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
-#include "../asmrun/spacetime.h"
+#include "caml/spacetime.h"
#endif
struct final {
#ifdef HAS_UNISTD
#include <unistd.h>
+#else
+#include <io.h>
#endif
#include "caml/debugger.h"
{
CAMLassert (unit == Val_unit);
return caml_alloc_sprintf
- ("a=%d,b=%s,H=%lu,i=%lu,l=%lu,o=%lu,O=%lu,p=%d,s=%lu,t=%d,v=%lu,w=%d,W=%lu",
- /* a */ caml_allocation_policy,
+ ("a=%d,b=%d,H=%lu,i=%lu,l=%lu,o=%lu,O=%lu,p=%d,s=%lu,t=%lu,v=%lu,w=%d,W=%lu",
+ /* a */ (int) caml_allocation_policy,
/* b */ caml_backtrace_active,
/* h */ /* missing */ /* FIXME add when changed to min_heap_size */
/* H */ caml_use_huge_pages,
/* i */ caml_major_heap_increment,
#ifdef NATIVE_CODE
- /* l */ 0,
+ /* l */ 0UL,
#else
/* l */ caml_max_stack_size,
#endif
{ 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_alloc_shr_aux(wosize, tag, 0, 0);
}
-#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
-#include "spacetime.h"
+#ifdef WITH_PROFINFO
+
+/* Use this to debug problems with macros... */
+#define NO_PROFINFO 0xff
CAMLexport value caml_alloc_shr_with_profinfo (mlsize_t wosize, tag_t tag,
intnat profinfo)
return caml_alloc_shr_with_profinfo (wosize, tag, Profinfo_hd(old_header));
}
+#else
+#define NO_PROFINFO 0
+#endif /* WITH_PROFINFO */
+
+#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+#include "caml/spacetime.h"
+
CAMLexport value caml_alloc_shr (mlsize_t wosize, tag_t tag)
{
return caml_alloc_shr_with_profinfo (wosize, tag,
#else
CAMLexport value caml_alloc_shr (mlsize_t wosize, tag_t tag)
{
- return caml_alloc_shr_aux (wosize, tag, 1, 0);
+ return caml_alloc_shr_aux (wosize, tag, 1, NO_PROFINFO);
}
#endif
/* PR#6084 workaround: define it as a weak symbol */
CAMLexport CAMLweakdef void caml_initialize (value *fp, value val)
{
- CAMLassert(Is_in_heap(fp));
+ CAMLassert(Is_in_heap_or_young(fp));
*fp = val;
- if (Is_block (val) && Is_young (val)) {
+ if (!Is_young((value)fp) && Is_block (val) && Is_young (val)) {
add_to_ref_table (&caml_ref_table, fp);
}
}
tbl->size = sz;
tbl->reserve = rsv;
- new_table = (void *) caml_stat_alloc ((tbl->size + tbl->reserve)
- * element_size);
+ new_table = (void *) malloc((tbl->size + tbl->reserve) * element_size);
+ if (new_table == NULL) caml_fatal_error ("Fatal error: not enough memory\n");
if (tbl->base != NULL) caml_stat_free (tbl->base);
tbl->base = new_table;
tbl->ptr = tbl->base;
#include "caml/config.h"
#include "caml/misc.h"
#include "caml/memory.h"
+#include "caml/osdeps.h"
#include "caml/version.h"
caml_timing_hook caml_major_slice_begin_hook = NULL;
fprintf (stderr, "file %s; line %d ### Assertion failed: %s\n",
file, line, expr);
fflush (stderr);
- exit (100);
+ abort();
}
void caml_set_fields (value v, unsigned long start, unsigned long filler)
char *s;
CAML_INSTR_STARTTIME = 0;
- s = getenv ("OCAML_INSTR_START");
+ s = caml_secure_getenv ("OCAML_INSTR_START");
if (s != NULL) CAML_INSTR_STARTTIME = atol (s);
CAML_INSTR_STOPTIME = LONG_MAX;
- s = getenv ("OCAML_INSTR_STOP");
+ s = caml_secure_getenv ("OCAML_INSTR_STOP");
if (s != NULL) CAML_INSTR_STOPTIME = atol (s);
}
FILE *f = NULL;
char *fname;
- fname = getenv ("OCAML_INSTR_FILE");
+ fname = caml_secure_getenv ("OCAML_INSTR_FILE");
if (fname != NULL){
char *mode = "a";
char buf [1000];
#include "caml/misc.h"
#include "caml/mlvalues.h"
#include "caml/prims.h"
-#include "spacetime.h"
+#include "caml/spacetime.h"
/* [size] is a value encoding a number of bytes */
CAMLprim value caml_static_alloc(value size)
caml_print_exception_backtrace();
}
+int caml_abort_on_uncaught_exn = 0; /* see afl.c */
+
void caml_fatal_uncaught_exception(value exn)
{
value *handle_uncaught_exception;
else
default_fatal_uncaught_exception(exn);
/* Terminate the process */
- CAML_SYS_EXIT(2);
- exit(2); /* Second exit needed for the Noreturn flag */
+ if (caml_abort_on_uncaught_exn) {
+ abort();
+ } else {
+ CAML_SYS_EXIT(2);
+ exit(2); /* Second exit needed for the Noreturn flag */
+ }
}
#include "caml/sys.h"
#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
-#include "../asmrun/spacetime.h"
+#include "caml/spacetime.h"
#endif
#ifndef NSIG
+++ /dev/null
-/**************************************************************************/
-/* */
-/* 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
char buf [2];
truename = caml_search_exe_in_path(*name);
- *name = truename;
caml_gc_message(0x100, "Opening bytecode executable %s\n",
(uintnat) truename);
fd = open(truename, O_RDONLY | O_BINARY);
if (fd == -1) {
+ caml_stat_free(truename);
caml_gc_message(0x100, "Cannot open file\n", 0);
return FILE_NOT_FOUND;
}
err = read (fd, buf, 2);
if (err < 2 || (buf [0] == '#' && buf [1] == '!')) {
close(fd);
+ caml_stat_free(truename);
caml_gc_message(0x100, "Rejected #! script\n", 0);
return BAD_BYTECODE;
}
err = read_trailer(fd, trail);
if (err != 0) {
close(fd);
+ caml_stat_free(truename);
caml_gc_message(0x100, "Not a bytecode executable\n", 0);
return err;
}
+ *name = truename;
return fd;
}
struct channel * chan;
value res;
char * shared_lib_path, * shared_libs, * req_prims;
- char * exe_name;
- static char proc_self_exe[256];
+ char * exe_name, * proc_self_exe;
ensure_spacetime_dot_o_is_included++;
exe_name = argv[0];
fd = caml_attempt_open(&exe_name, &trail, 0);
- /* Should we really do that at all? The current executable is ocamlrun
- itself, it's never a bytecode program. */
- if (fd < 0
- && caml_executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0) {
+ /* Little grasshopper wonders why we do that at all, since
+ "The current executable is ocamlrun itself, it's never a bytecode
+ program". Little grasshopper "ocamlc -custom" in mind should keep.
+ With -custom, we have an executable that is ocamlrun itself
+ concatenated with the bytecode. So, if the attempt with argv[0]
+ failed, it is worth trying again with executable_name. */
+ if (fd < 0 && (proc_self_exe = caml_executable_name()) != NULL) {
exe_name = proc_self_exe;
fd = caml_attempt_open(&exe_name, &trail, 0);
}
caml_sys_init(exe_name, argv + pos);
#ifdef _WIN32
/* Start a thread to handle signals */
- if (getenv("CAMLSIGPIPE"))
+ if (caml_secure_getenv("CAMLSIGPIPE"))
_beginthread(caml_signal_thread, 4096, NULL);
#endif
/* Execute the program */
/* Main entry point when code is linked in as initialized data */
-CAMLexport void caml_startup_code(
+CAMLexport value caml_startup_code_exn(
code_t code, asize_t code_size,
char *data, asize_t data_size,
char *section_table, asize_t section_table_size,
char **argv)
{
- value res;
char * cds_file;
char * exe_name;
- static char proc_self_exe[256];
caml_init_ieee_floats();
#if defined(_MSC_VER) && __STDC_SECURE_LIB__ >= 200411L
#ifdef DEBUG
caml_verb_gc = 63;
#endif
- cds_file = getenv("CAML_DEBUG_FILE");
+ cds_file = caml_secure_getenv("CAML_DEBUG_FILE");
if (cds_file != NULL) {
caml_cds_file = caml_strdup(cds_file);
}
caml_parse_ocamlrunparam();
- exe_name = argv[0];
- if (caml_executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0)
- exe_name = proc_self_exe;
+ exe_name = caml_executable_name();
+ if (exe_name == NULL) exe_name = caml_search_exe_in_path(argv[0]);
caml_external_raise = NULL;
/* Initialize the abstract machine */
caml_init_gc (caml_init_minor_heap_wsz, caml_init_heap_wsz,
caml_sys_init(exe_name, argv);
/* Execute the program */
caml_debugger(PROGRAM_START);
- res = caml_interprete(caml_start_code, caml_code_size);
+ return caml_interprete(caml_start_code, caml_code_size);
+}
+
+CAMLexport void caml_startup_code(
+ code_t code, asize_t code_size,
+ char *data, asize_t data_size,
+ char *section_table, asize_t section_table_size,
+ char **argv)
+{
+ value res;
+
+ res = caml_startup_code_exn(code, code_size, data, data_size,
+ section_table, section_table_size,
+ argv);
if (Is_exception_result(res)) {
caml_exn_bucket = Extract_exception(res);
if (caml_debugger_in_use) {
#include <stdio.h>
#include "caml/backtrace.h"
#include "caml/memory.h"
+#include "caml/osdeps.h"
#include "caml/startup_aux.h"
void caml_parse_ocamlrunparam(void)
{
- char *opt = getenv ("OCAMLRUNPARAM");
+ char *opt = caml_secure_getenv ("OCAMLRUNPARAM");
uintnat p;
- if (opt == NULL) opt = getenv ("CAMLRUNPARAM");
+ if (opt == NULL) opt = caml_secure_getenv ("CAMLRUNPARAM");
if (opt != NULL){
while (*opt != '\0'){
#include <time.h>
#include <sys/types.h>
#include <sys/stat.h>
-#if _WIN32
+#ifdef _WIN32
#include <io.h> /* for isatty */
#else
#include <sys/wait.h>
return caml_copy_string(buff);
}
-CAMLprim value caml_sys_getenv(value var)
+CAMLprim value caml_sys_unsafe_getenv(value var)
{
char * res;
return caml_copy_string(res);
}
+CAMLprim value caml_sys_getenv(value var)
+{
+ char * res;
+
+ if (! caml_string_is_c_safe(var)) caml_raise_not_found();
+ res = caml_secure_getenv(String_val(var));
+ if (res == 0) caml_raise_not_found();
+ return caml_copy_string(res);
+}
+
char * caml_exe_name;
char ** caml_main_argv;
CAMLreturn (Val_int(retcode));
}
-double caml_sys_time_unboxed(value unit)
+double caml_sys_time_include_children_unboxed(value include_children)
{
#ifdef HAS_GETRUSAGE
struct rusage ru;
+ double acc = 0.;
getrusage (RUSAGE_SELF, &ru);
- return ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1e6
+ acc += ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1e6
+ ru.ru_stime.tv_sec + ru.ru_stime.tv_usec / 1e6;
+
+ if (Bool_val(include_children)) {
+ getrusage (RUSAGE_CHILDREN, &ru);
+ acc += ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1e6
+ + ru.ru_stime.tv_sec + ru.ru_stime.tv_usec / 1e6;
+ }
+
+ return acc;
#else
#ifdef HAS_TIMES
#ifndef CLK_TCK
#endif
#endif
struct tms t;
+ clock_t acc = 0;
times(&t);
- return (double)(t.tms_utime + t.tms_stime) / CLK_TCK;
+ acc += t.tms_utime + t.tms_stime;
+ if (Bool_val(include_children)) {
+ acc += t.tms_cutime + t.tms_cstime;
+ }
+ return (double)acc / CLK_TCK;
#else
- /* clock() is standard ANSI C */
+ /* clock() is standard ANSI C. We have no way of getting
+ subprocess times in this branch. */
return (double)clock() / CLOCKS_PER_SEC;
#endif
#endif
}
+CAMLprim value caml_sys_time_include_children(value include_children)
+{
+ return caml_copy_double(caml_sys_time_include_children_unboxed(include_children));
+}
+
+double caml_sys_time_unboxed(value unit) {
+ return caml_sys_time_include_children_unboxed(Val_false);
+}
+
CAMLprim value caml_sys_time(value unit)
{
return caml_copy_double(caml_sys_time_unboxed(unit));
void caml_cplugins_load(char *env_variable)
{
- char *plugins = getenv(env_variable);
+ char *plugins = caml_secure_getenv(env_variable);
if(plugins != NULL){
char* curs = plugins;
while(*curs != 0){
#define _GNU_SOURCE
/* Helps finding RTLD_DEFAULT in glibc */
+ /* also secure_getenv */
#include <stddef.h>
#include <stdlib.h>
#else
#include <sys/dir.h>
#endif
+#ifdef __APPLE__
+#include <mach-o/dyld.h>
+#endif
#include "caml/fail.h"
#include "caml/memory.h"
#include "caml/misc.h"
/* Recover executable name from /proc/self/exe if possible */
-#ifdef __linux__
-
-int caml_executable_name(char * name, int name_len)
+char * caml_executable_name(void)
{
- int retcode;
+#if defined(__linux__)
+ int namelen, retcode;
+ char * name;
struct stat st;
- retcode = readlink("/proc/self/exe", name, name_len);
- if (retcode == -1 || retcode >= name_len) return -1;
+ /* lstat("/proc/self/exe") returns st_size == 0 so we cannot use it
+ to determine the size of the buffer. Instead, we guess and adjust. */
+ namelen = 256;
+ while (1) {
+ name = caml_stat_alloc(namelen + 1);
+ retcode = readlink("/proc/self/exe", name, namelen);
+ if (retcode == -1) { caml_stat_free(name); return NULL; }
+ if (retcode <= namelen) break;
+ caml_stat_free(name);
+ if (namelen >= 1024*1024) return NULL; /* avoid runaway and overflow */
+ namelen *= 2;
+ }
+ /* readlink() does not zero-terminate its result */
name[retcode] = 0;
/* Make sure that the contents of /proc/self/exe is a regular file.
(Old Linux kernels return an inode number instead.) */
- if (stat(name, &st) != 0) return -1;
- if (! S_ISREG(st.st_mode)) return -1;
- return 0;
-}
-
+ if (stat(name, &st) == -1 || ! S_ISREG(st.st_mode)) {
+ caml_stat_free(name); return NULL;
+ }
+ return name;
+
+#elif defined(__APPLE__)
+ unsigned int namelen;
+ char * name;
+
+ namelen = 256;
+ name = caml_stat_alloc(namelen);
+ if (_NSGetExecutablePath(name, &namelen) == 0) return name;
+ caml_stat_free(name);
+ /* Buffer is too small, but namelen now contains the size needed */
+ name = caml_stat_alloc(namelen);
+ if (_NSGetExecutablePath(name, &namelen) == 0) return name;
+ caml_stat_free(name);
+ return NULL;
+
#else
+ return NULL;
-int caml_executable_name(char * name, int name_len)
-{
- return -1;
+#endif
}
+char *caml_secure_getenv (char const *var)
+{
+#ifdef HAS_SECURE_GETENV
+ return secure_getenv (var);
+#elif defined (HAS___SECURE_GETENV)
+ return __secure_getenv (var);
+#elif defined(HAS_ISSETUGID)
+ if (!issetugid ())
+ return CAML_SYS_GETENV (var);
+ else
+ return NULL;
+#else
+ if (geteuid () == getuid () && getegid () == getgid ())
+ return CAML_SYS_GETENV (var);
+ else
+ return NULL;
#endif
+}
if (is_ephe_key_none(ar, offset)) CAMLreturn (None_val);
v = Field (ar, offset);
- if (Is_block (v) && Is_in_heap_or_young(v)) {
+ /** Don't copy custom_block #7279 */
+ if (Is_block (v) && Is_in_heap_or_young(v) && Tag_val(v) != Custom_tag ) {
elt = caml_alloc (Wosize_val (v), Tag_val (v));
/* The GC may erase or move v during this call to caml_alloc. */
v = Field (ar, offset);
memmove (Bp_val (elt), Bp_val (v), Bosize_val (v));
}
}else{
+ if ( caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(v) ){
+ caml_darken (v, NULL);
+ };
elt = v;
}
res = caml_alloc_small (1, Some_tag);
v = Field (ar, offset);
if (caml_gc_phase == Phase_clean) caml_ephe_clean(ar);
if (v == caml_ephe_none) CAMLreturn (None_val);
- if (Is_block (v) && Is_in_heap_or_young(v)) {
+ /** Don't copy custom_block #7279 */
+ if (Is_block (v) && Is_in_heap_or_young(v) && Tag_val(v) != Custom_tag ) {
elt = caml_alloc (Wosize_val (v), Tag_val (v));
/* The GC may erase or move v during this call to caml_alloc. */
v = Field (ar, offset);
memmove (Bp_val (elt), Bp_val (v), Bosize_val (v));
}
}else{
+ if ( caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(v) ){
+ caml_darken (v, NULL);
+ };
elt = v;
}
res = caml_alloc_small (1, Some_tag);
return;
}
prefix = caml_strdup(pat);
+ /* We need to stop at the first directory or drive boundary, because the
+ * _findata_t structure contains the filename, not the leading directory. */
for (i = strlen(prefix); i > 0; i--) {
char c = prefix[i - 1];
if (c == '\\' || c == '/' || c == ':') { prefix[i] = 0; break; }
}
+ /* No separator was found, it's a filename pattern without a leading directory. */
+ if (i == 0)
+ prefix[0] = 0;
do {
name = caml_strconcat(2, prefix, ffblk.name);
store_argument(name);
char *endptr;
HANDLE h;
/* Get an hexa-code raw handle through the environment */
- h = (HANDLE) (uintptr_t) strtol(getenv("CAMLSIGPIPE"), &endptr, 16);
+ h = (HANDLE) (uintptr_t)
+ strtol(caml_secure_getenv("CAMLSIGPIPE"), &endptr, 16);
while (1) {
DWORD numread;
BOOL ret;
/* Recover executable name */
-int caml_executable_name(char * name, int name_len)
+char * caml_executable_name(void)
{
- int retcode;
-
- int ret = GetModuleFileName(NULL, name, name_len);
- if (0 == ret || ret >= name_len) return -1;
- return 0;
+ char * name;
+ DWORD namelen, ret;
+
+ namelen = 256;
+ while (1) {
+ name = caml_stat_alloc(namelen);
+ ret = GetModuleFileName(NULL, name, namelen);
+ if (ret == 0) { caml_stat_free(name); return NULL; }
+ if (ret < namelen) break;
+ caml_stat_free(name);
+ if (namelen >= 1024*1024) return NULL; /* avoid runaway and overflow */
+ namelen *= 2;
+ }
+ return name;
}
/* snprintf emulation */
return len;
}
#endif
+
+char *caml_secure_getenv (char const *var)
+{
+ /* Win32 doesn't have a notion of setuid bit, so getenv is safe. */
+ return CAML_SYS_GETENV (var);
+}
### Whether profiling with gprof is supported
# If yes: (e.g. x86/Linux, Sparc/Solaris):
-#PROFILING=prof
+#PROFILING=true
# If no:
-#PROFILING=noprof
+#PROFILING=false
### Option to give to the C compiler for profiling
#CC_PROFILE=-pg
#CC_PROFILE=-xpg
-### How to perform a partial link
-PARTIALLD=ld -r $(NATIVECCLINKOPTS)
-
############# Configuration for the contributed libraries
### Which libraries to compile and install
### Where to install the binaries
BINDIR=$(PREFIX)/bin
+### Standard runtime system
+BYTERUN=ocamlrun
+
### Where to install the standard library
LIBDIR=$(PREFIX)/lib
MANEXT=1
HASHBANGSCRIPTS=false
PTHREAD_LINK=
+PTHREAD_CAML_LINK=
X11_INCLUDES=
X11_LINK=
BYTECCRPATH=
SUPPORTS_SHARED_LIBRARIES=true
-SHAREDCCCOMPOPTS=-O
+SHAREDCCCOMPOPTS=
MKSHAREDLIBRPATH=
NATIVECCPROFOPTS=
NATIVECCRPATH=
ASM=$(TOOLPREF)as
ASPP=$(TOOLPREF)gcc -c
ASPPPROFFLAGS=
-PROFILING=noprof
+PROFILING=false
DYNLINKOPTS=
CC_PROFILE=
SYSTHREAD_SUPPORT=true
EXTRALIBS=
NATDYNLINK=true
+NATDYNLINKOPTS=
CMXS=cmxs
-RUNTIMED=noruntimed
+RUNTIMED=false
ASM_CFI_SUPPORTED=false
+WITH_FRAME_POINTERS=false
+UNIX_OR_WIN32=win32
UNIXLIB=win32unix
GRAPHLIB=win32graph
FLAMBDA=false
WITH_SPACETIME=false
+WITH_PROFINFO=false
LIBUNWIND_AVAILABLE=false
LIBUNWIND_LINK_FLAGS=
PROFINFO_WIDTH=26
SAFE_STRING=false
+AFL_INSTRUMENT=false
########## Configuration for the bytecode compiler
### Which C compiler to use for the bytecode interpreter.
-BYTECC=$(TOOLPREF)gcc
+BYTECC=$(TOOLPREF)gcc -O -mms-bitfields
+BYTECODE_C_COMPILER=$(BYTECC)
### Additional compile-time options for $(BYTECC). (For static linking.)
-BYTECCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused
+BYTECCCOMPOPTS=-DCAML_NAME_SPACE -Wall -Wno-unused
### Additional compile-time options for $(BYTECC). (For debug version.)
BYTECCDBGCOMPOPTS=-g
### Additional link-time options for $(BYTECC). (For static linking.)
BYTECCLINKOPTS=
-### Additional compile-time options for $(BYTECC). (For building a DLL.)
-DLLCCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused -DCAML_DLL
-
### Libraries needed
BYTECCLIBS=-lws2_32
NATIVECCLIBS=-lws2_32
FLEXLINK_CMD=flexlink
FLEXDLL_CHAIN=mingw
# FLEXLINK_FLAGS must be safe to insert in an OCaml string
-# (see ocamlmklibconfig.ml in tools/Makefile.nt)
+# (see ocamlmklibconfig.ml in tools/Makefile)
FLEXLINK_FLAGS=-chain $(FLEXDLL_CHAIN) -stack 16777216 -link -static-libgcc
FLEXLINK=$(FLEXLINK_CMD) $(FLEXLINK_FLAGS)
FLEXDIR:=$(shell $(FLEXLINK) -where 2>/dev/null)
# or OCAML_FLEXLINK overriding will not work (see utils/config.mlp)
MKDLL=$(FLEXLINK)
MKEXE=$(FLEXLINK) -exe
+MKEXEDEBUGFLAG=-g
MKMAINDLL=$(FLEXLINK) -maindll
### Native command to build ocamlrun.exe without flexlink
### Which C compiler to use for the native-code compiler.
NATIVECC=$(BYTECC)
+NATIVE_C_COMPILER=$(NATIVECC)
### Additional compile-time options for $(NATIVECC).
-NATIVECCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused
+NATIVECCCOMPOPTS=-DCAML_NAME_SPACE -Wall -Wno-unused
### Additional link-time options for $(NATIVECC)
NATIVECCLINKOPTS=
BNG_ARCH=ia32
BNG_ASM_LEVEL=1
-############# Aliases for common commands
-
-MAKEREC=$(MAKE) -f Makefile.nt
-MAKECMD=$(MAKE)
-
############# for the testsuite makefiles
#ml let topdir = "" and wintopdir = "";;
OTOPDIR=$(WINTOPDIR)
CTOPDIR=$(TOPDIR)
CYGPATH=cygpath -m
-DIFF=diff -q --strip-trailing-cr
+DIFF=/usr/bin/diff -q --strip-trailing-cr
SET_LD_PATH=PATH="$(PATH):$(LD_PATH)"
MAX_TESTSUITE_DIR_RETRIES=1
### Where to install the binaries
BINDIR=$(PREFIX)/bin
+### Standard runtime system
+BYTERUN=ocamlrun
+
### Where to install the standard library
LIBDIR=$(PREFIX)/lib
MANEXT=1
HASHBANGSCRIPTS=false
PTHREAD_LINK=
+PTHREAD_CAML_LINK=
X11_INCLUDES=
X11_LINK=
BYTECCRPATH=
SUPPORTS_SHARED_LIBRARIES=true
-SHAREDCCCOMPOPTS=-O
+SHAREDCCCOMPOPTS=
MKSHAREDLIBRPATH=
NATIVECCPROFOPTS=
NATIVECCRPATH=
ASM=$(TOOLPREF)as
ASPP=$(TOOLPREF)gcc -c
ASPPPROFFLAGS=
-PROFILING=noprof
+PROFILING=false
DYNLINKOPTS=
CC_PROFILE=
SYSTHREAD_SUPPORT=true
EXTRALIBS=
NATDYNLINK=true
+NATDYNLINKOPTS=
CMXS=cmxs
-RUNTIMED=noruntimed
+RUNTIMED=false
ASM_CFI_SUPPORTED=false
+WITH_FRAME_POINTERS=false
+UNIX_OR_WIN32=win32
UNIXLIB=win32unix
GRAPHLIB=win32graph
FLAMBDA=false
+WITH_PROFINFO=false
WITH_SPACETIME=false
LIBUNWIND_AVAILABLE=false
LIBUNWIND_LINK_FLAGS=
PROFINFO_WIDTH=26
SAFE_STRING=false
+AFL_INSTRUMENT=false
########## Configuration for the bytecode compiler
### Which C compiler to use for the bytecode interpreter.
-BYTECC=$(TOOLPREF)gcc
+BYTECC=$(TOOLPREF)gcc -O -mms-bitfields
+BYTECODE_C_COMPILER=$(BYTECC)
### Additional compile-time options for $(BYTECC). (For static linking.)
-BYTECCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused
+BYTECCCOMPOPTS=-DCAML_NAME_SPACE -Wall -Wno-unused
### Additional compile-time options for $(BYTECC). (For debug version.)
BYTECCDBGCOMPOPTS=-g
### Additional link-time options for $(BYTECC). (For static linking.)
BYTECCLINKOPTS=
-### Additional compile-time options for $(BYTECC). (For building a DLL.)
-DLLCCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused -DCAML_DLL
-
### Libraries needed
BYTECCLIBS=-lws2_32
NATIVECCLIBS=-lws2_32
FLEXLINK_CMD=flexlink
FLEXDLL_CHAIN=mingw64
# FLEXLINK_FLAGS must be safe to insert in an OCaml string
-# (see ocamlmklibconfig.ml in tools/Makefile.nt)
+# (see ocamlmklibconfig.ml in tools/Makefile)
FLEXLINK_FLAGS=-chain $(FLEXDLL_CHAIN) -stack 33554432
FLEXLINK=$(FLEXLINK_CMD) $(FLEXLINK_FLAGS)
FLEXDIR:=$(shell $(FLEXLINK) -where 2>/dev/null)
# or OCAML_FLEXLINK overriding will not work (see utils/config.mlp)
MKDLL=$(FLEXLINK)
MKEXE=$(FLEXLINK) -exe
+MKEXEDEBUGFLAG=-g
MKMAINDLL=$(FLEXLINK) -maindll
### Native command to build ocamlrun.exe without flexlink
### Which C compiler to use for the native-code compiler.
NATIVECC=$(BYTECC)
+NATIVE_C_COMPILER=$(NATIVECC)
### Additional compile-time options for $(NATIVECC).
-NATIVECCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused
+NATIVECCCOMPOPTS=-DCAML_NAME_SPACE -Wall -Wno-unused
### Additional link-time options for $(NATIVECC)
NATIVECCLINKOPTS=
BNG_ARCH=amd64
BNG_ASM_LEVEL=1
-############# Aliases for common commands
-
-MAKEREC=$(MAKE) -f Makefile.nt
-MAKECMD=$(MAKE)
-
############# for the testsuite makefiles
#ml let topdir = "" and wintopdir = "";;
OTOPDIR=$(WINTOPDIR)
CTOPDIR=$(TOPDIR)
CYGPATH=cygpath -m
-DIFF=diff -q --strip-trailing-cr
+DIFF=/usr/bin/diff -q --strip-trailing-cr
SET_LD_PATH=PATH="$(PATH):$(LD_PATH)"
MAX_TESTSUITE_DIR_RETRIES=1
### Where to install the binaries.
BINDIR=$(PREFIX)/bin
+### Standard runtime system
+BYTERUN=ocamlrun
+
### Where to install the standard library
LIBDIR=$(PREFIX)/lib
MANEXT=1
HASHBANGSCRIPTS=false
PTHREAD_LINK=
+PTHREAD_CAML_LINK=
X11_INCLUDES=
X11_LINK=
BYTECCRPATH=
SUPPORTS_SHARED_LIBRARIES=true
-SHAREDCCCOMPOPTS=-Ox
+SHAREDCCCOMPOPTS=
NATIVECCPROFOPTS=
NATIVECCRPATH=
ASM=ml -nologo -coff -Cp -c -Fo
ASPP=
ASPPPROFFLAGS=
-PROFILING=noprof
+PROFILING=false
DYNLINKOPTS=
CC_PROFILE=
SYSTHREAD_SUPPORT=true
EXTRALIBS=
CMXS=cmxs
NATDYNLINK=true
-RUNTIMED=noruntimed
+NATDYNLINKOPTS=
+RUNTIMED=false
ASM_CFI_SUPPORTED=false
+WITH_FRAME_POINTERS=false
+UNIX_OR_WIN32=win32
UNIXLIB=win32unix
GRAPHLIB=win32graph
FLAMBDA=false
+WITH_PROFINFO=false
WITH_SPACETIME=false
LIBUNWIND_AVAILABLE=false
LIBUNWIND_LINK_FLAGS=
PROFINFO_WIDTH=26
SAFE_STRING=false
+AFL_INSTRUMENT=false
########## Configuration for the bytecode compiler
### Which C compiler to use for the bytecode interpreter.
-BYTECC=cl -nologo -D_CRT_SECURE_NO_DEPRECATE
+BYTECC=cl -nologo -D_CRT_SECURE_NO_DEPRECATE -O2 -Gy- -MD
+BYTECODE_C_COMPILER=$(BYTECC)
### Additional compile-time options for $(BYTECC). (For static linking.)
-BYTECCCOMPOPTS=-O2 -Gy- -MD
+BYTECCCOMPOPTS=-DCAML_NAME_SPACE
### Additional compile-time options for $(BYTECC). (For debug version.)
BYTECCDBGCOMPOPTS=-Zi
### Additional link-time options for $(BYTECC). (For static linking.)
BYTECCLINKOPTS=
-### Additional compile-time options for $(BYTECC). (For building a DLL.)
-DLLCCCOMPOPTS=-O2 -Gy- -MD
-
### Libraries needed
BYTECCLIBS=advapi32.lib ws2_32.lib
NATIVECCLIBS=advapi32.lib ws2_32.lib
FLEXLINK_CMD=flexlink
FLEXDLL_CHAIN=msvc
# FLEXLINK_FLAGS must be safe to insert in an OCaml string
-# (see ocamlmklibconfig.ml in tools/Makefile.nt)
+# (see ocamlmklibconfig.ml in tools/Makefile)
FLEXLINK_FLAGS=-merge-manifest -stack 16777216
FLEXLINK=$(FLEXLINK_CMD) $(FLEXLINK_FLAGS)
FLEXDIR:=$(shell $(FLEXLINK) -where 2>/dev/null)
# or OCAML_FLEXLINK overriding will not work (see utils/config.mlp)
MKDLL=$(FLEXLINK)
MKEXE=$(FLEXLINK) -exe
+MKEXEDEBUGFLAG=
MKMAINDLL=$(FLEXLINK) -maindll
### Native command to build ocamlrun.exe without flexlink
SYSTEM=win32
### Which C compiler to use for the native-code compiler.
-NATIVECC=cl -nologo -D_CRT_SECURE_NO_DEPRECATE
-
+NATIVECC=cl -nologo -D_CRT_SECURE_NO_DEPRECATE -O2 -Gy- -MD
+NATIVE_C_COMPILER=$(NATIVECC)
### Additional compile-time options for $(NATIVECC).
-NATIVECCCOMPOPTS=-O2 -Gy- -MD
+NATIVECCCOMPOPTS=-DCAML_NAME_SPACE
### Additional link-time options for $(NATIVECC)
NATIVECCLINKOPTS=
BNG_ARCH=generic
BNG_ASM_LEVEL=0
-############# Aliases for common commands
-
-MAKEREC=$(MAKE) -f Makefile.nt
-MAKECMD=$(MAKE)
-
############# for the testsuite makefiles
#ml let topdir = "" and wintopdir = "";;
OTOPDIR=$(WINTOPDIR)
CTOPDIR=$(WINTOPDIR)
CYGPATH=cygpath -m
-DIFF=diff -q --strip-trailing-cr
+DIFF=/usr/bin/diff -q --strip-trailing-cr
FIND=/usr/bin/find
SORT=/usr/bin/sort
SET_LD_PATH=PATH="$(PATH):$(LD_PATH)"
### Where to install the binaries.
BINDIR=$(PREFIX)/bin
+### Standard runtime system
+BYTERUN=ocamlrun
+
### Where to install the standard library
LIBDIR=$(PREFIX)/lib
MANEXT=1
HASHBANGSCRIPTS=false
PTHREAD_LINK=
+PTHREAD_CAML_LINK=
X11_INCLUDES=
X11_LINK=
BYTECCRPATH=
SUPPORTS_SHARED_LIBRARIES=true
-SHAREDCCCOMPOPTS=-Ox
+SHAREDCCCOMPOPTS=
NATIVECCPROFOPTS=
NATIVECCRPATH=
ASM=ml64 -nologo -Cp -c -Fo
ASPP=
ASPPPROFFLAGS=
-PROFILING=noprof
+PROFILING=false
DYNLINKOPTS=
CC_PROFILE=
SYSTHREAD_SUPPORT=true
CMXS=cmxs
NATDYNLINK=true
-RUNTIMED=noruntimed
+NATDYNLINKOPTS=
+RUNTIMED=false
ASM_CFI_SUPPORTED=false
+WITH_FRAME_POINTERS=false
+UNIX_OR_WIN32=win32
UNIXLIB=win32unix
GRAPHLIB=win32graph
FLAMBDA=false
+WITH_PROFINFO=false
WITH_SPACETIME=false
LIBUNWIND_AVAILABLE=false
LIBUNWIND_LINK_FLAGS=
PROFINFO_WIDTH=26
SAFE_STRING=false
+AFL_INSTRUMENT=false
########## Configuration for the bytecode compiler
### Which C compiler to use for the bytecode interpreter.
-BYTECC=cl -nologo -D_CRT_SECURE_NO_DEPRECATE
+BYTECC=cl -nologo -D_CRT_SECURE_NO_DEPRECATE -O2 -Gy- -MD
+BYTECODE_C_COMPILER=$(BYTECC)
### Additional compile-time options for $(BYTECC). (For static linking.)
-BYTECCCOMPOPTS=-O2 -Gy- -MD
+BYTECCCOMPOPTS=-DCAML_NAME_SPACE
### Additional compile-time options for $(BYTECC). (For debug version.)
BYTECCDBGCOMPOPTS=-Zi
### Additional link-time options for $(BYTECC). (For static linking.)
BYTECCLINKOPTS=
-### Additional compile-time options for $(BYTECC). (For building a DLL.)
-DLLCCCOMPOPTS=-O2 -Gy- -MD
-
### Libraries needed
#EXTRALIBS=bufferoverflowu.lib # for the old PSDK compiler only
EXTRALIBS=
FLEXLINK_CMD=flexlink
FLEXDLL_CHAIN=msvc64
# FLEXLINK_FLAGS must be safe to insert in an OCaml string
-# (see ocamlmklibconfig.ml in tools/Makefile.nt)
+# (see ocamlmklibconfig.ml in tools/Makefile)
FLEXLINK_FLAGS=-x64 -merge-manifest -stack 33554432
FLEXLINK=$(FLEXLINK_CMD) $(FLEXLINK_FLAGS)
FLEXDIR:=$(shell $(FLEXLINK) -where 2>/dev/null)
# or OCAML_FLEXLINK overriding will not work (see utils/config.mlp)
MKDLL=$(FLEXLINK)
MKEXE=$(FLEXLINK) -exe
+MKEXEDEBUGFLAG=
MKMAINDLL=$(FLEXLINK) -maindll
### Native command to build ocamlrun.exe without flexlink
SYSTEM=win64
### Which C compiler to use for the native-code compiler.
-NATIVECC=cl -nologo
+NATIVECC=cl -nologo -O2 -Gy- -MD
+NATIVE_C_COMPILER=$(NATIVECC)
### Additional compile-time options for $(NATIVECC).
-NATIVECCCOMPOPTS=-O2 -Gy- -MD
+NATIVECCCOMPOPTS=-DCAML_NAME_SPACE
### Additional link-time options for $(NATIVECC)
NATIVECCLINKOPTS=
BNG_ARCH=generic
BNG_ASM_LEVEL=0
-############# Aliases for common commands
-
-MAKEREC=$(MAKE) -f Makefile.nt
-MAKECMD=$(MAKE)
-
############# for the testsuite makefiles
#ml let topdir = "" and wintopdir = "";;
OTOPDIR=$(WINTOPDIR)
CTOPDIR=$(WINTOPDIR)
CYGPATH=cygpath -m
-DIFF=diff -q --strip-trailing-cr
+DIFF=/usr/bin/diff -q --strip-trailing-cr
FIND=/usr/bin/find
SORT=/usr/bin/sort
SET_LD_PATH=PATH="$(PATH):$(LD_PATH)"
--- /dev/null
+#! /usr/bin/env cat
+exit 1
#undef NONSTANDARD_DIV_MOD
-#define PROFINFO_WIDTH 26
+#define PROFINFO_WIDTH 0
+
+/* 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
dl_defs=''
verbose=no
with_curses=yes
-debugruntime=noruntimed
+debugruntime=false
with_instrumented_runtime=false
with_sharedlibs=yes
partialld="ld -r"
with_ocamldoc=ocamldoc
with_frame_pointers=false
with_spacetime=false
+with_profinfo=false
+profinfo_width=0
no_naked_pointers=false
native_compiler=true
TOOLPREF=""
with_cfi=true
flambda=false
safe_string=false
+afl_instrument=false
max_testsuite_dir_retries=0
with_cplugins=true
with_fpic=false
-verbose|--verbose)
verbose=yes;;
-with-debug-runtime|--with-debug-runtime)
- debugruntime=runtimed;;
+ debugruntime=true;;
-with-instrumented-runtime|--with-instrumented-runtime)
with_instrumented_runtime=true;;
-no-debugger|--no-debugger)
-no-naked-pointers|--no-naked-pointers)
no_naked_pointers=true;;
-spacetime|--spacetime)
- with_spacetime=true;;
+ with_spacetime=true; with_profinfo=true; profinfo_width=26;;
+ -reserved-header-bits|--reserved-header-bits)
+ with_spacetime=false; with_profinfo=true; profinfo_width=$2;shift
+ case $profinfo_width in
+ 0) with_profinfo=false;;
+ [0123456789]);;
+ 1?|2?);;
+ 3[012]);;
+ *) err "--reserved-header-bits argument must be less than 32"
+ esac
+ ;;
-no-cfi|--no-cfi)
with_cfi=false;;
-no-native-compiler|--no-native-compiler)
with_fpic=true;;
-safe-string|--safe-string)
safe_string=true;;
+ -afl-instrument)
+ afl_instrument=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 '=')."
bindir="$prefix/bin";;
*) echo "BINDIR=$bindir" >> Makefile;;
esac
+
+echo 'BYTERUN=$(BINDIR)/ocamlrun' >> Makefile
+
case "$libdir" in
"") echo 'LIBDIR=$(PREFIX)/lib/ocaml' >> Makefile
libdir="$prefix/lib/ocaml";;
# Determine the system type
if test "$host_type" = "unknown"; then
- if host_type=`../gnu/config.guess`; then :; else
+ if host_type=`sh ../gnu/config.guess`; then :; else
err "Cannot guess host type. You must specify one with the -host option."
fi
fi
-if host=`../gnu/config.sub $host_type`; then :; else
+if host=`sh ../gnu/config.sub $host_type`; then :; else
err "Please specify the correct host type with the -host option"
fi
inf "Configuring for host $host ..."
# Configure the bytecode compiler
+# The BYTECC make variable defines which compiler and options to use
+# to compile C code intended to be used by OCaml bytecode programs.
+# It is used inside OCaml's build system.
+
+# The BYTECODE_C_COMPILER make variable says how the C compiler should be
+# invoked to process a third-party C source file passed to ocamlc
+# when no -cc command-line option has been specified.
+
+# The BYTECCCOMPOPTS make variable contains options to pass to the C
+# compiler but only when compiling C files that belong to the OCaml
+# distribution.
+# In other words, when ocamlc is called to compile a third-party C
+# source file, it will _not_ pass these options to the C compiler.
+
+# The SHAREDCCCOMPOPTS make variable contains options to use to compile C
+# source files so that the resulting object files can then be integrated
+# into shared libraries. It is passed to BYTECC for both C source files
+# in the OCaml distribution and third-party C source files compiled
+# with ocamlc.
+
bytecc="$cc"
mkexe="\$(BYTECC)"
mkexedebugflag="-g"
bytecccompopts=""
+byteccprivatecompopts=""
bytecclinkopts=""
-dllccompopts=""
ostype="Unix"
exe=""
iflexdir=""
case "$ccfamily" in
clang-*)
- bytecccompopts="-O2 -fno-strict-aliasing -fwrapv $gcc_warnings";;
+ bytecccompopts="-O2 -fno-strict-aliasing -fwrapv";
+ byteccprivatecompopts="$gcc_warnings";;
gcc-[012]-*)
# Some versions known to miscompile OCaml, e,g, 2.7.2.1, some 2.96.
# Plus: C99 support unknown.
# Known problems with -fwrapv fixed in 4.2 only.
wrn "This version of GCC is rather old. Reducing optimization level."
wrn "Consider using GCC version 4.2 or above."
- bytecccompopts="-std=gnu99 -O $gcc_warnings";;
+ bytecccompopts="-std=gnu99 -O";
+ byteccprivatecompopts="$gcc_warnings";;
+ gcc-4-*)
+ bytecccompopts="-std=gnu99 -O2 -fno-strict-aliasing -fwrapv \
+-fno-builtin-memcmp";
+ byteccprivatecompopts="$gcc_warnings";;
gcc-*)
- bytecccompopts="-std=gnu99 -O2 -fno-strict-aliasing -fwrapv $gcc_warnings";;
+ bytecccompopts="-O2 -fno-strict-aliasing -fwrapv";
+ byteccprivatecompopts="$gcc_warnings";;
*)
bytecccompopts="-O";;
esac
+byteccprivatecompopts="-DCAML_NAME_SPACE $byteccprivatecompopts"
+
# Adjust according to target
case "$bytecc,$target" in
*) err "unknown cygwin variant";;
esac
bytecccompopts="$bytecccompopts -U_WIN32"
- dllccompopts="-U_WIN32 -DCAML_DLL"
if test $with_sharedlibs = yes; then
flexlink="flexlink -chain $flavor -merge-manifest -stack 16777216"
flexdir=`$flexlink -where | tr -d '\015'`
# Check C compiler.
-cc="$bytecc $bytecccompopts $bytecclinkopts" sh ./runtest ansi.c
+cc="$bytecc $bytecccompopts $byteccprivatecompopts $bytecclinkopts" sh ./runtest ansi.c
case $? in
0) inf "The C compiler is ISO C99 compliant." ;;
1) wrn "The C compiler is ANSI / ISO C90 compliant, but not ISO C99" \
echo "#define SIZEOF_PTR $3" >> m.h
echo "#define SIZEOF_SHORT $4" >> m.h
echo "#define SIZEOF_LONGLONG $5" >> m.h
+echo "#define INT64_LITERAL(s) s ## LL" >> m.h
# Determine endianness
mksharedlib="$flexlink"
mkmaindll="$flexlink -maindll"
shared_libraries_supported=true;;
- *-*-linux-gnu|*-*-linux|*-*-freebsd[3-9]*|*-*-freebsd[1-9][0-9]*\
- |*-*-openbsd*|*-*-netbsd*|*-*-dragonfly*|*-*-gnu*|*-*-haiku*)
- sharedcccompopts="-fPIC"
- mksharedlib="$bytecc -shared"
- bytecclinkopts="$bytecclinkopts -Wl,-E"
- byteccrpath="-Wl,-rpath,"
- mksharedlibrpath="-Wl,-rpath,"
- natdynlinkopts="-Wl,-E"
- shared_libraries_supported=true;;
alpha*-*-osf*)
case "$bytecc" in
*gcc*)
bytecccompopts="$dl_defs $bytecccompopts"
dl_needs_underscore=false
shared_libraries_supported=true;;
- m88k-*-openbsd*)
- shared_libraries_supported=false;;
- vax-*-openbsd*)
- shared_libraries_supported=false;;
- *-*-openbsd*)
+ *-*-linux-gnu|*-*-linux|*-*-freebsd[3-9]*|*-*-freebsd[1-9][0-9]*\
+ |*-*-openbsd*|*-*-netbsd*|*-*-dragonfly*|*-*-gnu*|*-*-haiku*)
sharedcccompopts="-fPIC"
mksharedlib="$bytecc -shared"
bytecclinkopts="$bytecclinkopts -Wl,-E"
- natdynlinkopts="-Wl,-E"
byteccrpath="-Wl,-rpath,"
mksharedlibrpath="-Wl,-rpath,"
+ natdynlinkopts="-Wl,-E"
shared_libraries_supported=true;;
esac
fi
# Configure the native-code compiler
+# The NATIVECC make variable defines which compiler and options to use
+# to compile C code intended to be used by OCaml native programs.
+# It is used inside OCaml's build system.
+
+# The NATIVE_C_COMPILER make variable says how the C compiler should be
+# invoked to process a third-party C source file passed to ocamlopt
+# when no -cc command-line option has been specified.
+
+# The NATIVECCCOMPOPTS make variable contains options to pass to the C
+# compiler, but only when compiling C files that belong to the OCaml
+# distribution.
+# In other words, when ocamlopt is called to compile a third-party C
+# source file, it will _not_ pass these options to the C compiler.
+
arch=none
model=default
system=unknown
fi
nativecccompopts="$bytecccompopts"
+nativeccprivatecompopts="$byteccprivatecompopts"
nativeccprofopts=''
nativecclinkopts=''
# FIXME the naming of nativecclinkopts is broken: these are options for
aspp="${TOOLPREF}cc -c";;
amd64,*|arm,*|arm64,*|i386,*|power,bsd*|sparc,*)
as="${TOOLPREF}as"
- aspp="${TOOLPREF}gcc -c";;
+ case "$ccfamily" in
+ clang-*)
+ aspp="${TOOLPREF}clang -c"
+ ;;
+ *)
+ aspp="${TOOLPREF}gcc -c"
+ ;;
+ esac;;
esac
if test -n "$asoption"; then as="$asoption"; fi
cc_profile='-pg'
case "$arch,$system" in
- i386,linux_elf) profiling='prof';;
- i386,gnu) profiling='prof';;
- i386,bsd_elf) profiling='prof';;
- amd64,macosx) profiling='prof';;
- i386,macosx) profiling='prof';;
- sparc,bsd) profiling='prof';;
+ i386,linux_elf) profiling='true';;
+ i386,gnu) profiling='true';;
+ i386,bsd_elf) profiling='true';;
+ amd64,macosx) profiling='true';;
+ i386,macosx) profiling='true';;
+ sparc,bsd) profiling='true';;
sparc,solaris)
- profiling='prof'
+ profiling='true'
case "$nativecc" in gcc*) ;; *) cc_profile='-xpg';; esac;;
- amd64,linux) profiling='prof';;
- amd64,openbsd) profiling='prof';;
- amd64,freebsd) profiling='prof';;
- amd64,netbsd) profiling='prof';;
- arm,netbsd) profiling='prof';;
- amd64,gnu) profiling='prof';;
- arm,linux*) profiling='prof';;
- power,elf) profiling='prof';;
- power,bsd*) profiling='prof';;
- *) profiling='noprof';;
+ amd64,linux) profiling='true';;
+ amd64,openbsd) profiling='true';;
+ amd64,freebsd) profiling='true';;
+ amd64,netbsd) profiling='true';;
+ arm,netbsd) profiling='true';;
+ amd64,gnu) profiling='true';;
+ arm,linux*) profiling='true';;
+ power,elf) profiling='true';;
+ power,bsd*) profiling='true';;
+ *) profiling='false';;
esac
# Where is ranlib?
# Do #! scripts work?
-if (SHELL=/bin/sh; export SHELL; (./hashbang || ./hashbang2) >/dev/null); then
+printf "#!%s\nexit 1\n" `command -v cat` > hashbang4
+chmod +x hashbang4
+
+if ( (./hashbang || ./hashbang2 || ./hashbang3 || ./hashbang4) >/dev/null); then
inf "#! appears to work in shell scripts."
case "$target" in
*-*-sunos*|*-*-unicos*)
echo "#define HAS_TIMES" >> s.h
fi
+if sh ./hasgot2 -D_GNU_SOURCE -i stdlib.h secure_getenv; then
+ inf "secure_getenv() found."
+ echo "#define HAS_SECURE_GETENV" >> s.h
+elif sh ./hasgot2 -D_GNU_SOURCE -i stdlib.h __secure_getenv; then
+ inf "__secure_getenv() found."
+ echo "#define HAS___SECURE_GETENV" >> s.h
+fi
+
+if sh ./hasgot -i unistd.h issetugid; then
+ inf "issetugid() found."
+ echo "#define HAS_ISSETUGID" >> s.h
+fi
+
# For the terminfo module
if test "$with_curses" = "yes"; then
echo "#define HAS_NICE" >> s.h
fi
+if sh ./hasgot dup3; then
+ inf "dup3() found"
+ echo "#define HAS_DUP3" >> s.h
+fi
+
+if sh ./hasgot pipe2; then
+ inf "pipe2() found"
+ echo "#define HAS_PIPE2" >> s.h
+fi
+
+if sh ./hasgot accept4; then
+ inf "accept4() found"
+ echo "#define HAS_ACCEPT4" >> s.h
+fi
+
# Determine if the debugger is supported
if test -n "$with_debugger"; then
if test "$with_frame_pointers" = "true"; then
case "$target,$cc" in
- x86_64-*-linux*,gcc*)
+ x86_64-*-linux*,gcc*|x86_64-*-linux*,clang*)
nativecccompopts="$nativecccompopts -g -fno-omit-frame-pointer"
bytecccompopts="$bytecccompopts -g -fno-omit-frame-pointer"
nativecclinkopts="$nativecclinkopts -g"
# 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_profinfo; then
+ echo "#define WITH_PROFINFO" >> m.h
+fi
+
if $with_spacetime; then
case "$arch,$system" in
amd64,*)
cclibs="$cclibs $mathlib"
-echo "BYTECC=$bytecc" >> Makefile
-echo "BYTECCCOMPOPTS=$bytecccompopts" >> Makefile
+echo "BYTECC=$bytecc $bytecccompopts" >> Makefile
+echo "BYTECODE_C_COMPILER=$bytecc $bytecccompopts $sharedcccompopts" \
+ >> Makefile
+echo "BYTECCCOMPOPTS=$byteccprivatecompopts" >> Makefile
echo "BYTECCLINKOPTS=$bytecclinkopts" >> Makefile
echo "BYTECCLIBS=$cclibs $dllib $curseslibs $pthread_link \
$instrumented_runtime_libs" >> Makefile
echo "ARCH=$arch" >> Makefile
echo "MODEL=$model" >> Makefile
echo "SYSTEM=$system" >> Makefile
-echo "NATIVECC=$nativecc" >> Makefile
-echo "NATIVECCCOMPOPTS=$nativecccompopts" >> Makefile
+echo "NATIVECC=$nativecc $nativecccompopts" >> Makefile
+echo "NATIVE_C_COMPILER=$nativecc $nativecccompopts" >> Makefile
+echo "NATIVECCCOMPOPTS=$nativeccprivatecompopts" >> Makefile
echo "NATIVECCPROFOPTS=$nativeccprofopts" >> Makefile
echo "NATIVECCLINKOPTS=$nativecclinkopts" >> Makefile
echo "NATIVECCRPATH=$nativeccrpath" >> Makefile
echo "OTHERLIBRARIES=$otherlibraries" >> Makefile
echo "CC_PROFILE=$cc_profile" >> Makefile
echo "SYSTHREAD_SUPPORT=$systhread_support" >> Makefile
-echo "PARTIALLD=$partialld" >> Makefile
-echo "PACKLD=\$(PARTIALLD) \$(NATIVECCLINKOPTS) -o " \
- | sed -e 's/ $/\\ /' >> Makefile
-echo "DLLCCCOMPOPTS=$dllccompopts" >> Makefile
+echo "PACKLD=$partialld $nativecclinkopts -o\\ " >> Makefile
echo "IFLEXDIR=$iflexdir" >> Makefile
echo "O=o" >> Makefile
echo "A=a" >> Makefile
echo "MKDLL=$mksharedlib" >> Makefile
echo "MKMAINDLL=$mkmaindll" >> Makefile
echo "RUNTIMED=${debugruntime}" >>Makefile
-if $shared_libraries_supported; then
- echo "SHARED=shared" >>Makefile
-else
- echo "SHARED=noshared" >>Makefile
-fi
echo "RUNTIMEI=${with_instrumented_runtime}" >>Makefile
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 "WITH_PROFINFO=$with_profinfo" >> Makefile
echo "LIBUNWIND_AVAILABLE=$libunwind_available" >> Makefile
echo "LIBUNWIND_INCLUDE_FLAGS=$libunwind_include" >> Makefile
echo "LIBUNWIND_LINK_FLAGS=$libunwind_lib" >> Makefile
fi
echo "FLAMBDA=$flambda" >> Makefile
echo "SAFE_STRING=$safe_string" >> Makefile
+echo "AFL_INSTRUMENT=$afl_instrument" >> Makefile
echo "MAX_TESTSUITE_DIR_RETRIES=$max_testsuite_dir_retries" >> Makefile
else
inf " spacetime profiling....... no"
fi
+ if $with_profinfo; then
+ inf " reserved bits in header... $profinfo_width"
+ else
+ inf " reserved bits in header... no"
+ fi
case "$arch,$system" in
amd64,macosx)
;;
inf " compile with -fPIC........ no"
fi
inf " native dynlink ........... $natdynlink"
- if test "$profiling" = "prof"; then
+ if $profiling; then
inf " profiling with gprof ..... supported"
else
inf " profiling with gprof ..... not supported"
else
inf " safe strings ............. no"
fi
+ if test "$afl_instrument" = "true"; then
+ inf " afl-fuzz always enabled .. yes"
+ else
+ inf " afl-fuzz always enabled .. no"
+ fi
fi
if test "$with_debugger" = "ocamldebugger"; then
inf "Source-level replay debugger: not supported"
fi
-if test "$debugruntime" = "runtimed"; then
+if $debugruntime; then
inf "Debug runtime will be compiled and installed"
fi
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 \
- ../typing/ctype.cmi ../utils/config.cmi ../driver/compdynlink.cmi \
- loadprinter.cmi
+ ../parsing/longident.cmi ../parsing/location.cmi ../typing/ident.cmi \
+ ../typing/env.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 \
- ../typing/ctype.cmx ../utils/config.cmx ../driver/compdynlink.cmi \
- loadprinter.cmi
+ ../parsing/longident.cmx ../parsing/location.cmx ../typing/ident.cmx \
+ ../typing/env.cmx ../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 \
#* *
#**************************************************************************
+include ../config/Makefile
UNIXDIR=../otherlibs/$(UNIXLIB)
-include Makefile.shared
+CAMLRUN ?= ../boot/ocamlrun
+CAMLYACC ?= ../boot/ocamlyacc
+
+CAMLC=$(CAMLRUN) ../ocamlc -nostdlib -I ../stdlib
+COMPFLAGS=$(INCLUDES) -absname -w +a-4-9-41-42-44-45-48 -warn-error A \
+ -safe-string -strict-sequence -strict-formats
+LINKFLAGS=-linkall -I $(UNIXDIR)
+YACCFLAGS=
+CAMLLEX=$(CAMLRUN) ../boot/ocamllex
+CAMLDEP=$(CAMLRUN) ../tools/ocamldep
+DEPFLAGS=$(INCLUDES)
+
+INSTALL_BINDIR=$(DESTDIR)$(BINDIR)
+
+INCLUDES=\
+ -I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../toplevel \
+ -I ../driver -I $(UNIXDIR)
+
+OTHEROBJS=\
+ $(UNIXDIR)/unix.cma \
+ ../utils/config.cmo ../utils/tbl.cmo ../utils/misc.cmo \
+ ../utils/identifiable.cmo ../utils/numbers.cmo \
+ ../utils/arg_helper.cmo ../utils/clflags.cmo \
+ ../utils/consistbl.cmo ../utils/warnings.cmo \
+ ../utils/terminfo.cmo \
+ ../parsing/location.cmo ../parsing/longident.cmo ../parsing/docstrings.cmo \
+ ../parsing/syntaxerr.cmo \
+ ../parsing/ast_helper.cmo ../parsing/ast_mapper.cmo \
+ ../parsing/ast_iterator.cmo ../parsing/attr_helper.cmo \
+ ../parsing/builtin_attributes.cmo \
+ ../typing/ident.cmo ../typing/path.cmo ../typing/types.cmo \
+ ../typing/btype.cmo ../typing/primitive.cmo ../typing/typedtree.cmo \
+ ../typing/subst.cmo ../typing/predef.cmo \
+ ../typing/datarepr.cmo ../typing/cmi_format.cmo ../typing/env.cmo \
+ ../typing/oprint.cmo \
+ ../typing/ctype.cmo ../typing/printtyp.cmo ../typing/mtype.cmo \
+ ../typing/envaux.cmo \
+ ../bytecomp/runtimedef.cmo ../bytecomp/bytesections.cmo \
+ ../bytecomp/dll.cmo ../bytecomp/meta.cmo ../bytecomp/symtable.cmo \
+ ../bytecomp/opcodes.cmo ../driver/compdynlink.cmo \
+ ../toplevel/genprintval.cmo
+
+
+OBJS=\
+ int64ops.cmo \
+ primitives.cmo \
+ unix_tools.cmo \
+ debugger_config.cmo \
+ parameters.cmo \
+ lexer.cmo \
+ input_handling.cmo \
+ question.cmo \
+ debugcom.cmo \
+ exec.cmo \
+ source.cmo \
+ pos.cmo \
+ checkpoints.cmo \
+ events.cmo \
+ program_loading.cmo \
+ symbols.cmo \
+ breakpoints.cmo \
+ trap_barrier.cmo \
+ history.cmo \
+ printval.cmo \
+ show_source.cmo \
+ time_travel.cmo \
+ program_management.cmo \
+ frames.cmo \
+ eval.cmo \
+ show_information.cmo \
+ loadprinter.cmo \
+ parser.cmo \
+ command_line.cmo \
+ main.cmo
+
+all: ocamldebug$(EXE)
+
+ocamldebug$(EXE): $(OBJS) $(OTHEROBJS)
+ $(CAMLC) $(LINKFLAGS) -o ocamldebug$(EXE) -linkall $(OTHEROBJS) $(OBJS)
+
+install:
+ cp ocamldebug$(EXE) "$(INSTALL_BINDIR)/ocamldebug$(EXE)"
+
+clean::
+ rm -f ocamldebug$(EXE)
+ rm -f *.cmo *.cmi
+
+.SUFFIXES:
+.SUFFIXES: .ml .cmo .mli .cmi
+
+.ml.cmo:
+ $(CAMLC) -c $(COMPFLAGS) $<
+
+.mli.cmi:
+ $(CAMLC) -c $(COMPFLAGS) $<
+
+depend: beforedepend
+ $(CAMLDEP) -slash $(DEPFLAGS) *.mli *.ml \
+ | sed -e 's,$(UNIXDIR)/,$$(UNIXDIR)/,' > .depend
+
+lexer.ml: lexer.mll
+ $(CAMLLEX) lexer.mll
+clean::
+ rm -f lexer.ml
+beforedepend:: lexer.ml
+
+parser.ml parser.mli: parser.mly
+ $(CAMLYACC) parser.mly
+clean::
+ rm -f parser.ml parser.mli
+beforedepend:: parser.ml parser.mli
+
+include .depend
#* *
#**************************************************************************
-UNIXDIR=../otherlibs/win32unix
-include Makefile.shared
+include Makefile
+++ /dev/null
-#**************************************************************************
-#* *
-#* 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 ../config/Makefile
-CAMLRUN ?= ../boot/ocamlrun
-CAMLYACC ?= ../boot/ocamlyacc
-
-CAMLC=$(CAMLRUN) ../ocamlc -nostdlib -I ../stdlib
-COMPFLAGS=$(INCLUDES) -absname -w +a-4-9-41-42-44-45-48 -warn-error A \
- -safe-string -strict-sequence -strict-formats
-LINKFLAGS=-linkall -I $(UNIXDIR)
-YACCFLAGS=
-CAMLLEX=$(CAMLRUN) ../boot/ocamllex
-CAMLDEP=$(CAMLRUN) ../tools/ocamldep
-DEPFLAGS=$(INCLUDES)
-
-INSTALL_BINDIR=$(DESTDIR)$(BINDIR)
-
-INCLUDES=\
- -I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../toplevel \
- -I ../driver -I $(UNIXDIR)
-
-OTHEROBJS=\
- $(UNIXDIR)/unix.cma \
- ../utils/config.cmo ../utils/tbl.cmo ../utils/misc.cmo \
- ../utils/identifiable.cmo ../utils/numbers.cmo \
- ../utils/arg_helper.cmo ../utils/clflags.cmo \
- ../utils/consistbl.cmo ../utils/warnings.cmo \
- ../utils/terminfo.cmo \
- ../parsing/location.cmo ../parsing/longident.cmo ../parsing/docstrings.cmo \
- ../parsing/ast_helper.cmo ../parsing/ast_mapper.cmo \
- ../parsing/ast_iterator.cmo ../parsing/attr_helper.cmo \
- ../parsing/builtin_attributes.cmo \
- ../typing/ident.cmo ../typing/path.cmo ../typing/types.cmo \
- ../typing/btype.cmo ../typing/primitive.cmo ../typing/typedtree.cmo \
- ../typing/subst.cmo ../typing/predef.cmo \
- ../typing/datarepr.cmo ../typing/cmi_format.cmo ../typing/env.cmo \
- ../typing/oprint.cmo \
- ../typing/ctype.cmo ../typing/printtyp.cmo ../typing/mtype.cmo \
- ../typing/envaux.cmo \
- ../bytecomp/runtimedef.cmo ../bytecomp/bytesections.cmo \
- ../bytecomp/dll.cmo ../bytecomp/meta.cmo ../bytecomp/symtable.cmo \
- ../bytecomp/opcodes.cmo ../driver/compdynlink.cmo \
- ../toplevel/genprintval.cmo
-
-
-OBJS=\
- int64ops.cmo \
- primitives.cmo \
- unix_tools.cmo \
- debugger_config.cmo \
- parameters.cmo \
- lexer.cmo \
- input_handling.cmo \
- question.cmo \
- debugcom.cmo \
- exec.cmo \
- source.cmo \
- pos.cmo \
- checkpoints.cmo \
- events.cmo \
- program_loading.cmo \
- symbols.cmo \
- breakpoints.cmo \
- trap_barrier.cmo \
- history.cmo \
- printval.cmo \
- show_source.cmo \
- time_travel.cmo \
- program_management.cmo \
- frames.cmo \
- eval.cmo \
- show_information.cmo \
- loadprinter.cmo \
- parser.cmo \
- command_line.cmo \
- main.cmo
-
-all: ocamldebug$(EXE)
-
-ocamldebug$(EXE): $(OBJS) $(OTHEROBJS)
- $(CAMLC) $(LINKFLAGS) -o ocamldebug$(EXE) -linkall $(OTHEROBJS) $(OBJS)
-
-install:
- cp ocamldebug$(EXE) "$(INSTALL_BINDIR)/ocamldebug$(EXE)"
-
-clean::
- rm -f ocamldebug$(EXE)
- rm -f *.cmo *.cmi
-
-.SUFFIXES:
-.SUFFIXES: .ml .cmo .mli .cmi
-
-.ml.cmo:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.mli.cmi:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-depend: beforedepend
- $(CAMLDEP) -slash $(DEPFLAGS) *.mli *.ml \
- | sed -e 's,$(UNIXDIR)/,$$(UNIXDIR)/,' > .depend
-
-lexer.ml: lexer.mll
- $(CAMLLEX) lexer.mll
-clean::
- rm -f lexer.ml
-beforedepend:: lexer.ml
-
-parser.ml parser.mli: parser.mly
- $(CAMLYACC) parser.mly
-clean::
- rm -f parser.ml parser.mli
-beforedepend:: parser.ml parser.mli
-
-include .depend
| Not_found -> error ("No source file for " ^ mdle ^ ".") in
let point =
if column <> -1 then
- (point_of_coord buffer line 1) + column
+ try
+ (point_of_coord buffer line 1) + column
+ with Out_of_range ->
+ -1
else
-1 in
let beginning =
| Pdot(p, _, pos) -> Obj.field (eval_path p) pos
| Papply _ -> fatal_error "Loadprinter.eval_path"
+(* PR#7258: get rid of module aliases before evaluating paths *)
+
+let eval_path path =
+ eval_path (Env.normalize_path (Some Location.none) Env.empty path)
+
(* Install, remove a printer (as in toplevel/topdirs) *)
(* since 4.00, "topdirs.cmi" is not in the same directory as the standard
(* Print a line; return the beginning of the next line *)
let print_line buffer line_number start point before =
- let next = next_linefeed buffer start
+ let linefeed = next_linefeed buffer start
and content = buffer_content buffer
in
printf "%i " line_number;
- if point <= next && point >= start then
+ let line_end =
+ if linefeed > 0 && content.[linefeed - 1] = '\r' then
+ linefeed - 1
+ else
+ linefeed in
+ if point <= line_end && point >= start then
(print_string (String.sub content start (point - start));
print_string (if before then event_mark_before else event_mark_after);
- print_string (String.sub content point (next - point)))
+ print_string (String.sub content point (line_end - point)))
else
- print_string (String.sub content start (next - start));
+ print_string (String.sub content start (line_end - start));
print_newline ();
- next
+ linefeed
(* Tell Emacs we are nowhere in the source. *)
let show_no_point () =
| "g" -> set "g" [ Clflags.debug ] v
| "p" -> set "p" [ Clflags.gprofile ] v
| "bin-annot" -> set "bin-annot" [ Clflags.binary_annotations ] v
+ | "afl-instrument" -> set "afl-instrument" [ Clflags.afl_instrument ] v
+ | "afl-inst-ratio" ->
+ int_setter ppf "afl-inst-ratio" afl_inst_ratio v
| "annot" -> set "annot" [ Clflags.annotations ] v
| "absname" -> set "absname" [ Location.absname ] v
| "compat-32" -> set "compat-32" [ bytecode_compatible_32 ] v
(Warnings.Bad_env_variable ("OCAMLPARAM",
"bad value for \"color\", \
(expected \"auto\", \"always\" or \"never\")"))
- | Some setting -> color := setting
+ | Some setting -> color := Some setting
end
| "intf-suffix" -> Config.interface_suffix := v
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 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
- Printtyp.wrap_printing_env initial_env (fun () ->
- fprintf std_formatter "%a@."
- Printtyp.signature (Typemod.simplify_signature sg));
- ignore (Includemod.signatures initial_env sg sg);
- Typecore.force_delayed_checks ();
- Warnings.check_fatal ();
- if not !Clflags.print_types then begin
- let deprecated = Builtin_attributes.deprecated_of_sig ast in
- let sg =
- Env.save_signature ~deprecated sg modulename (outputprefix ^ ".cmi")
- in
- Typemod.save_signature modulename tsg outputprefix sourcefile
- initial_env sg ;
- end
+ Timings.(time_call (Typing sourcefile)) (fun () ->
+ 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
+ Printtyp.wrap_printing_env initial_env (fun () ->
+ fprintf std_formatter "%a@."
+ Printtyp.signature (Typemod.simplify_signature sg));
+ ignore (Includemod.signatures initial_env sg sg);
+ Typecore.force_delayed_checks ();
+ Warnings.check_fatal ();
+ if not !Clflags.print_types then begin
+ let deprecated = Builtin_attributes.deprecated_of_sig ast in
+ let sg =
+ Env.save_signature ~deprecated sg modulename (outputprefix ^ ".cmi")
+ in
+ Typemod.save_signature modulename tsg outputprefix sourcefile
+ initial_env sg ;
+ end
+ )
(* Compile a .ml file *)
else
!Clflags.include_dirs
in
- let dirs = !last_include_dirs @ dirs @ !first_include_dirs in
+ let dirs =
+ !last_include_dirs @ dirs @ Config.flexdll_dirs @ !first_include_dirs
+ in
let exp_dirs =
List.map (Misc.expand_directory Config.standard_library) dirs in
Config.load_path := dir ::
let open_implicit_module m env =
let open Asttypes in
let lid = {loc = Location.in_file "command line";
- txt = Longident.Lident m } in
+ txt = Longident.parse m } in
snd (Typemod.type_open_ Override env lid.loc lid)
let initial_env () =
List.fold_left (fun env m ->
open_implicit_module m env
) env (!implicit_modules @ List.rev !Clflags.open_modules)
+
+
+let read_color_env ppf =
+ try
+ match Clflags.parse_color_setting (Sys.getenv "OCAML_COLOR") with
+ | None ->
+ Location.print_warning Location.none ppf
+ (Warnings.Bad_env_variable
+ ("OCAML_COLOR",
+ "expected \"auto\", \"always\" or \"never\""));
+ | Some x -> match !Clflags.color with
+ | None -> Clflags.color := Some x
+ | Some _ -> ()
+ with
+ Not_found -> ()
val init_path : ?dir:string -> bool -> unit
val initial_env : unit -> Env.t
+
+val read_color_env : Format.formatter -> unit
let _warn_error = (Warnings.parse_options true)
let _warn_help = Warnings.help_warnings
let _color option =
- begin match Clflags.parse_color_setting option with
+ begin match parse_color_setting option with
| None -> ()
- | Some setting -> Clflags.color := setting
+ | Some setting -> color := Some setting
end
let _where = print_standard_library
let _verbose = set verbose
let _dlambda = set dump_lambda
let _dinstr = set dump_instr
let _dtimings = set print_timings
+
+ let _args = Arg.read_arg
+ let _args0 = Arg.read_arg0
+
let anonymous = anonymous
end)
let main () =
+ Clflags.add_arguments __LOC__ Options.list;
try
readenv ppf Before_args;
- Arg.parse Options.list anonymous usage;
- Compenv.process_deferred_actions
- (ppf,
- Compile.implementation,
- Compile.interface,
- ".cmo",
- ".cma");
+ Clflags.parse_arguments anonymous usage;
+ Compmisc.read_color_env ppf;
+ begin try
+ Compenv.process_deferred_actions
+ (ppf,
+ Compile.implementation,
+ Compile.interface,
+ ".cmo",
+ ".cma");
+ with Arg.Bad msg ->
+ begin
+ prerr_endline msg;
+ Clflags.print_arguments usage;
+ exit 2
+ end
+ end;
readenv ppf Before_link;
if
List.length (List.filter (fun x -> !x)
\ and instead fix invalid formats.)"
;;
+let mk_args f =
+ "-args", Arg.Expand f,
+ "<file> Read additional newline-terminated command line arguments\n\
+ \ from <file>"
+;;
+
+let mk_args0 f =
+ "-args0", Arg.Expand f,
+ "<file> Read additional null character terminated command line arguments\n\
+ from <file>"
+;;
+
+let mk_afl_instrument f =
+ "-afl-instrument", Arg.Unit f, "Enable instrumentation for afl-fuzz"
+;;
+
+let mk_afl_inst_ratio f =
+ "-afl-inst-ratio", Arg.Int f,
+ "Configure percentage of branches instrumented\n\
+ \ (advanced, see afl-fuzz docs for AFL_INST_RATIO)"
+;;
+
let mk__ f =
"-", Arg.String f,
"<file> Treat <file> as a file name (even if it starts with `-')"
val _nopervasives : unit -> unit
val _dtimings : unit -> unit
+
+ val _args: string -> string array
+ val _args0: string -> string array
end
;;
val _nopromptcont : unit -> unit
val _plugin : string -> unit
val _stdin : unit -> unit
+ val _args : string -> string array
+ val _args0 : string -> string array
end
;;
module type Bytetop_options = sig
include Toplevel_options
val _dinstr : unit -> unit
+
end;;
module type Optcommon_options = sig
val _pp : string -> unit
val _S : unit -> unit
val _shared : unit -> unit
+ val _afl_instrument : unit -> unit
+ val _afl_inst_ratio : int -> unit
end;;
module type Opttop_options = sig
mk_dlambda F._dlambda;
mk_dinstr F._dinstr;
mk_dtimings F._dtimings;
+
+ mk_args F._args;
+ mk_args0 F._args0;
]
end;;
mk_drawlambda F._drawlambda;
mk_dlambda F._dlambda;
mk_dinstr F._dinstr;
+
+ mk_args F._args;
+ mk_args0 F._args0;
]
end;;
let list = [
mk_a F._a;
mk_absname F._absname;
+ mk_afl_instrument F._afl_instrument;
+ mk_afl_inst_ratio F._afl_inst_ratio;
mk_annot F._annot;
mk_binannot F._binannot;
mk_inline_branch_factor F._inline_branch_factor;
mk_dstartup F._dstartup;
mk_dtimings F._dtimings;
mk_dump_pass F._dump_pass;
+
+ mk_args F._args;
+ mk_args0 F._args0;
]
end;;
val _nopervasives : unit -> unit
val _dtimings : unit -> unit
+
+ val _args: string -> string array
+ val _args0: string -> string array
end
;;
val _nopromptcont : unit -> unit
val _plugin : string -> unit
val _stdin : unit -> unit
+ val _args: string -> string array
+ val _args0: string -> string array
+
end
;;
val _pp : string -> unit
val _S : unit -> unit
val _shared : unit -> unit
+ val _afl_instrument : unit -> unit
+ val _afl_inst_ratio : int -> unit
end;;
module type Opttop_options = sig
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 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
- Printtyp.wrap_printing_env initial_env (fun () ->
- fprintf std_formatter "%a@."
- Printtyp.signature (Typemod.simplify_signature sg));
- ignore (Includemod.signatures initial_env sg sg);
- Typecore.force_delayed_checks ();
- Warnings.check_fatal ();
- if not !Clflags.print_types then begin
- let deprecated = Builtin_attributes.deprecated_of_sig ast in
- let sg =
- Env.save_signature ~deprecated sg modulename (outputprefix ^ ".cmi")
- in
- Typemod.save_signature modulename tsg outputprefix sourcefile
- initial_env sg ;
- end
+ Timings.(time_call (Typing sourcefile)) (fun () ->
+ 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
+ Printtyp.wrap_printing_env initial_env (fun () ->
+ fprintf std_formatter "%a@."
+ Printtyp.signature (Typemod.simplify_signature sg));
+ ignore (Includemod.signatures initial_env sg sg);
+ Typecore.force_delayed_checks ();
+ Warnings.check_fatal ();
+ if not !Clflags.print_types then begin
+ let deprecated = Builtin_attributes.deprecated_of_sig ast in
+ let sg =
+ Env.save_signature ~deprecated sg modulename (outputprefix ^ ".cmi")
+ in
+ Typemod.save_signature modulename tsg outputprefix sourcefile
+ initial_env sg ;
+ end
+ )
(* Compile a .ml file *)
let _a = set make_archive
let _absname = set Location.absname
+ let _afl_instrument = set afl_instrument
+ let _afl_inst_ratio n = afl_inst_ratio := n
let _annot = set annotations
let _binannot = set binary_annotations
let _c = set compile_only
let _warn_error s = Warnings.parse_options true s
let _warn_help = Warnings.help_warnings
let _color option =
- begin match Clflags.parse_color_setting option with
+ begin match parse_color_setting option with
| None -> ()
- | Some setting -> Clflags.color := setting
+ | Some setting -> color := Some setting
end
let _where () = print_standard_library ()
let _dtimings = set print_timings
let _opaque = set opaque
+ let _args = Arg.read_arg
+ let _args0 = Arg.read_arg0
+
let anonymous = anonymous
end);;
let ppf = Format.err_formatter in
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");
+ Clflags.add_arguments __LOC__ (Arch.command_line_options @ Options.list);
+ Clflags.parse_arguments anonymous usage;
+ Compmisc.read_color_env ppf;
+ if !gprofile && not Config.profiling then
+ fatal "Profiling with \"gprof\" is not supported on this platform.";
+ begin try
+ Compenv.process_deferred_actions
+ (ppf,
+ Optcompile.implementation ~backend,
+ Optcompile.interface,
+ ".cmx",
+ ".cmxa");
+ with Arg.Bad msg ->
+ begin
+ prerr_endline msg;
+ Clflags.print_arguments usage;
+ exit 2
+ end
+ end;
readenv ppf Before_link;
if
List.length (List.filter (fun x -> !x)
match !Clflags.preprocessor with
None -> sourcefile
| Some pp ->
- Timings.(time (Preprocessing sourcefile))
+ Timings.(time (Dash_pp sourcefile))
(call_external_preprocessor sourcefile) pp
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 source_file = !Location.input_name in
let (ic, is_ast_file) = open_and_check_magic inputfile ast_magic in
let ast =
try
Location.input_name := inputfile;
let lexbuf = Lexing.from_channel ic in
Location.init lexbuf inputfile;
- parse_fun lexbuf
+ Timings.(time_call (Parser source_file)) (fun () ->
+ parse_fun lexbuf)
end
with x -> close_in ic; raise x
in
close_in ic;
- let ast = apply_rewriters ~restore:false ~tool_name kind ast in
+ let ast =
+ Timings.(time_call (Dash_ppx source_file)) (fun () ->
+ apply_rewriters ~restore:false ~tool_name kind ast) in
if is_ast_file || !Clflags.all_ppx <> [] then invariant_fun ast;
ast
Location.input_name := sourcefile;
let inputfile = preprocess sourcefile in
let ast =
- let parse_fun = Timings.(time (Parsing sourcefile)) (parse kind) in
- try file_aux ppf ~tool_name inputfile parse_fun invariant_fun kind
+ try file_aux ppf ~tool_name inputfile (parse kind) invariant_fun kind
with exn ->
remove_preprocessed inputfile;
raise exn
end)
let parse_implementation ppf ~tool_name sourcefile =
- parse_file ~tool_name Ast_invariants.structure
- ImplementationHooks.apply_hooks Structure ppf sourcefile
+ Timings.(time_call (Parsing sourcefile)) (fun () ->
+ parse_file ~tool_name Ast_invariants.structure
+ ImplementationHooks.apply_hooks Structure ppf sourcefile)
let parse_interface ppf ~tool_name sourcefile =
- parse_file ~tool_name Ast_invariants.signature
- InterfaceHooks.apply_hooks Signature ppf sourcefile
+ Timings.(time_call (Parsing sourcefile)) (fun () ->
+ parse_file ~tool_name Ast_invariants.signature
+ InterfaceHooks.apply_hooks Signature ppf sourcefile)
(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)
- (caml-types-feedback kind)))))
+ (caml-types-feedback kind "%s call")))))
(if (and (= arg 4)
(not (window-live-p (get-buffer-window caml-types-buffer))))
(display-buffer caml-types-buffer))
let output_tables oc tbl =
output_string oc "let __ocaml_lex_tables = {\n";
- fprintf oc " Lexing.lex_base = \n%a;\n" output_array tbl.tbl_base;
- fprintf oc " Lexing.lex_backtrk = \n%a;\n" output_array tbl.tbl_backtrk;
- fprintf oc " Lexing.lex_default = \n%a;\n" output_array tbl.tbl_default;
- fprintf oc " Lexing.lex_trans = \n%a;\n" output_array tbl.tbl_trans;
- fprintf oc " Lexing.lex_check = \n%a;\n" output_array tbl.tbl_check;
- fprintf oc " Lexing.lex_base_code = \n%a;\n" output_array tbl.tbl_base_code;
-
- fprintf oc " Lexing.lex_backtrk_code = \n%a;\n"
+ fprintf oc " Lexing.lex_base =\n%a;\n" output_array tbl.tbl_base;
+ fprintf oc " Lexing.lex_backtrk =\n%a;\n" output_array tbl.tbl_backtrk;
+ fprintf oc " Lexing.lex_default =\n%a;\n" output_array tbl.tbl_default;
+ fprintf oc " Lexing.lex_trans =\n%a;\n" output_array tbl.tbl_trans;
+ fprintf oc " Lexing.lex_check =\n%a;\n" output_array tbl.tbl_check;
+ fprintf oc " Lexing.lex_base_code =\n%a;\n" output_array tbl.tbl_base_code;
+
+ fprintf oc " Lexing.lex_backtrk_code =\n%a;\n"
output_array tbl.tbl_backtrk_code;
- fprintf oc " Lexing.lex_default_code = \n%a;\n"
+ fprintf oc " Lexing.lex_default_code =\n%a;\n"
output_array tbl.tbl_default_code;
- fprintf oc " Lexing.lex_trans_code = \n%a;\n"
+ fprintf oc " Lexing.lex_trans_code =\n%a;\n"
output_array tbl.tbl_trans_code;
- fprintf oc " Lexing.lex_check_code = \n%a;\n"
+ fprintf oc " Lexing.lex_check_code =\n%a;\n"
output_array tbl.tbl_check_code;
- fprintf oc " Lexing.lex_code = \n%a;\n" output_byte_array tbl.tbl_code;
+ fprintf oc " Lexing.lex_code =\n%a;\n" output_byte_array tbl.tbl_code;
output_string oc "}\n\n"
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"
+ fprintf oc
+ "%s %alexbuf =\
+ \n %a%a __ocaml_lex_%s_rec %alexbuf %d\n"
e.auto_name
- output_args e.auto_args
+ output_args e.auto_args
(fun oc x ->
if x > 0 then
- fprintf oc "lexbuf.Lexing.lex_mem <- Array.make %d (-1) ; " x)
+ fprintf oc "lexbuf.Lexing.lex_mem <- Array.make %d (-1);" x)
e.auto_mem_size
(output_memory_actions " ") init_moves
e.auto_name
output_args e.auto_args
init_num;
fprintf oc "and __ocaml_lex_%s_rec %alexbuf __ocaml_lex_state =\n"
- e.auto_name output_args e.auto_args ;
+ e.auto_name output_args e.auto_args;
fprintf oc " match Lexing.%sengine"
(if e.auto_mem_size == 0 then "" else "new_");
fprintf oc " __ocaml_lex_tables __ocaml_lex_state lexbuf with\n ";
e.auto_actions;
if has_refill then
fprintf oc
- " | __ocaml_lex_state -> __ocaml_lex_refill \
- \n (fun lexbuf -> lexbuf.Lexing.refill_buff lexbuf; \
+ " | __ocaml_lex_state -> __ocaml_lex_refill\
+ \n (fun lexbuf -> lexbuf.Lexing.refill_buff lexbuf;\
\n __ocaml_lex_%s_rec %alexbuf __ocaml_lex_state) lexbuf\n\n"
e.auto_name output_args e.auto_args
else
fprintf oc
- " | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; \
+ " | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf;\
\n __ocaml_lex_%s_rec %alexbuf __ocaml_lex_state\n\n"
e.auto_name output_args e.auto_args
Array.length tables.tbl_check_code) +
Array.length tables.tbl_code) in
if size_groups > 0 && not !Common.quiet_mode then
- Printf.printf "%d additional bytes used for bindings\n" size_groups ;
+ Printf.printf "%d additional bytes used for bindings\n" size_groups;
flush stdout;
if Array.length tables.tbl_trans > 0x8000 then raise Table_overflow;
copy_chunk ic oc oci header false;
checks that the "TERM" environment variable exists and is
not empty or "dumb", and that isatty(stderr) holds.
+The environment variable "OCAML_COLOR" is considered if \-color is not
+provided. Its values are auto/always/never as above.
+
.TP
.B \-compat\-32
Check that the generated bytecode executable can run on 32-bit
command on executables produced by
.BR ocamlc\ \-custom ,
this would remove the bytecode part of the executable.
+
+Security warning: never set the "setuid" or "setgid" bits on
+executables produced by
+.BR ocamlc\ \-custom ,
+this would make them vulnerable to attacks.
.TP
.BI \-dllib\ \-l libname
Arrange for the C shared library
.B \-linkall
option forces all subsequent links of programs involving that library
to link all the modules contained in the library.
+When compiling a module (option
+.BR \-c ),
+setting the
+.B \-linkall
+option ensures that this module will
+always be linked if it is put in a library and this library is linked.
.TP
.B \-make\-runtime
Build a custom runtime system (in the file specified by option
cmo file, and also sets the module name to the file name up to the
first dot.
.TP
+.B \-opaque
+Interface file compiled with this option are marked so that other
+compilation units depending on it will not rely on any implementation
+details of the compiled implementation. The native compiler will not
+access the .cmx file of this unit -- nor warn if it is absent. This can
+improve speed of compilation, for both initial and incremental builds,
+at the expense of performance of the generated code.
+.TP
.BI \-open \ module
Opens the given module before processing the interface or
implementation files. If several
is opened before parsing each of the
following files.
.TP
+.BI \-plugin \ plugin
+Dynamically load the code of the given
+.I plugin
+(a .cmo, .cma or .cmxs file) in
+.BR ocamldep (1).
+The plugin must exist in
+the same kind of code as the tool (
+.BR ocamldep.byte
+must load bytecode
+plugins, while
+.BR ocamldep.opt
+must load native code plugins), and
+extension adaptation is done automatically for .cma files (to .cmxs files
+if
+.BR ocamldep (1)
+is compiled in native code).
+.TP
.BI \-pp \ command
Cause
.BR ocamldep (1)
causes the C linker to search for C libraries in
directory
.IR dir .
+.TP
+.BI \-color \ mode
+Enable or disable colors in compiler messages (especially warnings and errors).
+The following modes are supported:
+
+.B auto
+use heuristics to enable colors only if the output supports them (an
+ANSI-compatible tty terminal);
+
+.B always
+enable colors unconditionally;
+
+.B never
+disable color output.
+
+The default setting is
+.B auto,
+and the current heuristic
+checks that the "TERM" environment variable exists and is
+not empty or "dumb", and that isatty(stderr) holds.
+
+The environment variable "OCAML_COLOR" is considered if \-color is not
+provided. Its values are auto/always/never as above.
+
.TP
.B \-compact
Optimize the produced code for space rather than for time. This
flag forces all
subsequent links of programs involving that library to link all the
modules contained in the library.
+When compiling a module (option
+.BR \-c ),
+setting the
+.B \-linkall
+option ensures that this module will
+always be linked if it is put in a library and this library is linked.
.TP
.B \-no-alias-deps
Do not record dependencies for module aliases.
cmo file, and also sets the module name to the file name up to the
first dot.
.TP
+.B \-opaque
+When compiling a .mli interface file, this has the same effect as the
+.B \-opaque
+option of the bytecode compiler. When compiling a .ml implementation
+file, this produces a .cmx file without cross-module optimization
+information, which reduces recompilation on module change.
+.TP
.BI \-open \ module
Opens the given module before processing the interface or
implementation files. If several
let create = Unit_id.create
let get_compilation_unit = Unit_id.unit
+let name = Unit_id.name
include Identifiable.S
val create : ?name:string -> Compilation_unit.t -> t
+val name : t -> string option
val get_compilation_unit : t -> Compilation_unit.t
include Set_of_closures_id
let create t = t
+let rename f t = f t
val create : Set_of_closures_id.t -> t
val get_compilation_unit : t -> Compilation_unit.t
+val rename : (Set_of_closures_id.t -> Set_of_closures_id.t) -> t -> t
}
let add_default_argument_wrappers lam =
- (* CR-someday mshinwell: Temporary hack to mark default argument wrappers
- as stubs. Other possibilities:
- 1. Change Lambda.inline_attribute to add another ("stub") case;
- 2. Add a "stub" field to the Lfunction record. *)
- let stubify body : Lambda.lambda =
- let stub_prim =
- Primitive.simple ~name:Closure_conversion_aux.stub_hack_prim_name
- ~arity:1 ~alloc:false
- in
- 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
| Llet (( Strict | Alias | StrictOpt), _k, id,
Lfunction {kind; params; body = fbody; attr; loc}, body) ->
begin match
- Simplif.split_default_wrapper ~id ~kind ~params ~body:fbody
- ~attr ~wrapper_attr:Lambda.default_function_attribute
- ~loc ~create_wrapper_body:stubify ()
+ Simplif.split_default_wrapper ~id ~kind ~params
+ ~body:fbody ~attr ~loc
with
| [fun_id, def] -> Llet (Alias, Pgenval, fun_id, def, body)
| [fun_id, def; inner_fun_id, def_inner] ->
(function
| (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 ()
+ ~attr ~loc
| _ -> assert false)
defs)
in
let set_of_closures =
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 ~loc
+ ~params ~body ~attr ~loc
in
close_functions t env (Function_decls.create [decl])
in
let function_declaration =
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 ~loc
+ ~attr ~loc
in
Some function_declaration
| _ -> None)
argument with a default value, make sure it always gets inlined.
CR-someday pchambart: eta-expansion wrapper for a primitive are
not marked as stub but certainly should *)
- let stub, body =
- match Function_decl.primitive_wrapper decl with
- | None -> false, body
- | Some wrapper_body -> true, wrapper_body
- in
+ let stub = Function_decl.stub decl in
let params = List.map (Env.find_var closure_env) params in
let closure_bound_var = Function_decl.closure_bound_var decl in
let body = close t closure_env body in
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 ~loc
+ ~body ~attr ~loc
in
let set_of_closures_var =
Variable.rename let_bound_var ~append:"_set_of_closures"
let not_at_toplevel t = { t with at_toplevel = false; }
end
-let stub_hack_prim_name = "*stub*"
-
module Function_decls = struct
module Function_decl = struct
type t = {
params : Ident.t list;
body : Lambda.lambda;
free_idents_of_body : IdentSet.t;
- inline : Lambda.inline_attribute;
- specialise : Lambda.specialise_attribute;
- is_a_functor : bool;
+ attr : Lambda.function_attribute;
loc : Location.t;
}
- let create ~let_rec_ident ~closure_bound_var ~kind ~params ~body ~inline
- ~specialise ~is_a_functor ~loc =
+ let create ~let_rec_ident ~closure_bound_var ~kind ~params ~body
+ ~attr ~loc =
let let_rec_ident =
match let_rec_ident with
| None -> Ident.create "unnamed_function"
params;
body;
free_idents_of_body = Lambda.free_variables body;
- inline;
- specialise;
- is_a_functor;
+ attr;
loc;
}
let params t = t.params
let body t = t.body
let free_idents t = t.free_idents_of_body
- let inline t = t.inline
- let specialise t = t.specialise
- let is_a_functor t = t.is_a_functor
+ let inline t = t.attr.inline
+ let specialise t = t.attr.specialise
+ let is_a_functor t = t.attr.is_a_functor
+ let stub t = t.attr.stub
let loc t = t.loc
- let primitive_wrapper t =
- match t.body with
- | Lprim (Pccall { Primitive. prim_name; }, [body], _)
- when prim_name = stub_hack_prim_name -> Some body
- | _ -> None
end
type t = {
-> kind:Lambda.function_kind
-> params:Ident.t list
-> body:Lambda.lambda
- -> inline:Lambda.inline_attribute
- -> specialise:Lambda.specialise_attribute
- -> is_a_functor:bool
+ -> attr:Lambda.function_attribute
-> loc:Location.t
-> t
val inline : t -> Lambda.inline_attribute
val specialise : t -> Lambda.specialise_attribute
val is_a_functor : t -> bool
+ val stub : t -> bool
val loc : t -> Location.t
- (* [primitive_wrapper t] is [None] iff [t] is not a wrapper for a function
- with default optional arguments. Otherwise it is [Some body], where
- [body] is the body of the wrapper. *)
- val primitive_wrapper : t -> Lambda.lambda option
-
(* Like [all_free_idents], but for just one function. *)
val free_idents : t -> Lambda.IdentSet.t
end
It also contains the globals bindings of the provided environment. *)
val closure_env_without_parameters : Env.t -> t -> Env.t
end
-
-val stub_hack_prim_name : string
let concat dbg1 dbg2 =
dbg1 @ dbg2
+(* CR-someday afrisch: FWIW, the current compare function does not seem very
+ good, since it reverses the two lists. I don't know how long the lists are,
+ nor if the specific currently implemented ordering is useful in other
+ contexts, but if one wants to use Map, a more efficient comparison should
+ be considered. *)
let compare dbg1 dbg2 =
let rec loop ds1 ds2 =
match ds1, ds2 with
loop ds1 ds2
in
loop (List.rev dbg1) (List.rev dbg2)
+
+let hash t =
+ List.fold_left (fun hash item -> Hashtbl.hash (hash, item)) 0 t
+
+let rec print_compact ppf t =
+ let print_item item =
+ Format.fprintf ppf "%a:%i"
+ Location.print_filename item.dinfo_file
+ item.dinfo_line;
+ if item.dinfo_char_start >= 0 then begin
+ Format.fprintf ppf ",%i--%i" item.dinfo_char_start item.dinfo_char_end
+ end
+ in
+ match t with
+ | [] -> ()
+ | [item] -> print_item item
+ | item::t ->
+ print_item item;
+ Format.fprintf ppf ";";
+ print_compact ppf t
val inline: Location.t -> t -> t
val compare : t -> t -> int
+
+val hash : t -> int
+
+val print_compact : Format.formatter -> t -> unit
funs;
}
+let import_function_declarations_for_pack function_decls
+ import_set_of_closures_id import_set_of_closures_origin =
+ { set_of_closures_id =
+ import_set_of_closures_id function_decls.set_of_closures_id;
+ set_of_closures_origin =
+ import_set_of_closures_origin function_decls.set_of_closures_origin;
+ funs = function_decls.funs;
+ }
+
let create_set_of_closures ~function_decls ~free_vars ~specialised_args
~direct_call_surrogates =
if !Clflags.flambda_invariant_checks then begin
-> funs:function_declaration Variable.Map.t
-> function_declarations
+val import_function_declarations_for_pack
+ : function_declarations
+ -> (Set_of_closures_id.t -> Set_of_closures_id.t)
+ -> (Set_of_closures_origin.t -> Set_of_closures_origin.t)
+ -> function_declarations
+
(** Create a set of closures. Checks are made to ensure that [free_vars]
and [specialised_args] are reasonable. *)
val create_set_of_closures
exception Pidentity_should_not_occur
exception Pdirapply_should_be_expanded
exception Prevapply_should_be_expanded
+exception Ploc_should_be_expanded
exception Sequential_logical_operator_primitives_must_be_expanded of
Lambda.primitive
exception Var_within_closure_bound_multiple_times of Var_within_closure.t
| Pidentity -> raise Pidentity_should_not_occur
| Pdirapply -> raise Pdirapply_should_be_expanded
| Prevapply -> raise Prevapply_should_be_expanded
+ | Ploc _ -> raise Ploc_should_be_expanded
| _ -> ()
end
| _ -> ())
Flambda expression (see closure_conversion.ml)"
| Pdirapply_should_be_expanded ->
Format.eprintf ">> The Pdirapply primitive should never occur in an \
- Flambda expression (see closure_conversion.ml); use Apply instead"
+ Flambda expression (see simplif.ml); use Apply instead"
| Prevapply_should_be_expanded ->
Format.eprintf ">> The Prevapply primitive should never occur in an \
- Flambda expression (see closure_conversion.ml); use Apply instead"
+ Flambda expression (see simplif.ml); use Apply instead"
+ | Ploc_should_be_expanded ->
+ Format.eprintf ">> The Ploc primitive should never occur in an \
+ Flambda expression (see translcore.ml); use Apply instead"
| Move_to_a_closure_not_in_the_free_variables (start_from, move_to) ->
Format.eprintf ">> A Move_within_set_of_closures from the closure %a \
to closures that are not parts of its free variables: %a"
| Wrong ->
Misc.fatal_errorf "Wrong approximation when projecting closure: %a"
Flambda.print_project_closure project_closure
- | Unresolved symbol ->
+ | Unresolved value ->
(* A set of closures coming from another compilation unit, whose .cmx is
missing; as such, we cannot have rewritten the function and don't
need to do any freshening. *)
Project_closure {
set_of_closures;
closure_id = project_closure.closure_id;
- }, ret r (A.value_unresolved symbol)
+ }, ret r (A.value_unresolved value)
| Unknown ->
(* CR-soon mshinwell: see CR comment in e.g. simple_value_approx.ml
[check_approx_for_closure_allowing_unresolved] *)
set_of_closures;
closure_id = project_closure.closure_id;
}, ret r (A.value_unknown Other)
- | Unknown_because_of_unresolved_symbol symbol ->
+ | Unknown_because_of_unresolved_value value ->
Project_closure {
set_of_closures;
closure_id = project_closure.closure_id;
- }, ret r (A.value_unknown (Unresolved_symbol symbol))
+ }, ret r (A.value_unknown (Unresolved_value value))
| Ok (set_of_closures_var, value_set_of_closures) ->
let closure_id =
A.freshen_and_check_closure_id value_set_of_closures
move_to = move_within_set_of_closures.move_to;
},
ret r (A.value_unknown Other)
- | Unknown_because_of_unresolved_symbol sym ->
+ | Unknown_because_of_unresolved_value value ->
(* For example: a move upon a (move upon a closure whose .cmx file
is missing). *)
Move_within_set_of_closures {
start_from = move_within_set_of_closures.start_from;
move_to = move_within_set_of_closures.move_to;
},
- ret r (A.value_unknown (Unresolved_symbol sym))
+ ret r (A.value_unknown (Unresolved_value value))
| Ok (_value_closure, set_of_closures_var, set_of_closures_symbol,
value_set_of_closures) ->
let freshen =
| Unknown ->
Project_var { project_var with closure },
ret r (A.value_unknown Other)
- | Unknown_because_of_unresolved_symbol symbol ->
+ | Unknown_because_of_unresolved_value value ->
Project_var { project_var with closure },
- ret r (A.value_unknown (Unresolved_symbol symbol))
+ ret r (A.value_unknown (Unresolved_value value))
| Wrong ->
(* We must have the correct approximation of the value to ensure
we take account of all freshenings. *)
begin match prim, args, args_approxs with
| Pgetglobal _, _, _ ->
Misc.fatal_error "Pgetglobal is forbidden in Inline_and_simplify"
+ (* CR-someday mshinwell: Optimise [Pfield_computed]. *)
| Pfield field_index, [arg], [arg_approx] ->
let projection : Projection.t = Field (field_index, arg) in
begin match E.find_projection env ~projection with
| Flambda.Symbol sym -> begin
match E.find_symbol_opt env sym with
| Some approx -> approx
- | None -> A.value_unresolved sym
+ | None -> A.value_unresolved (Symbol sym)
end
| Flambda.Const cst -> simplify_const cst)
fields
| Project_closure (set_of_closures_symbol, closure_id) -> begin
match E.find_symbol_opt env set_of_closures_symbol with
| None ->
- A.value_unresolved set_of_closures_symbol
+ A.value_unresolved (Symbol set_of_closures_symbol)
| Some set_of_closures_approx ->
let checked_approx =
A.check_approx_for_set_of_closures set_of_closures_approx
A.value_closure value_set_of_closures closure_id
| Unresolved sym -> A.value_unresolved sym
| Unknown -> A.value_unknown Other
- | Unknown_because_of_unresolved_symbol sym ->
- A.value_unknown (Unresolved_symbol sym)
+ | Unknown_because_of_unresolved_value value ->
+ A.value_unknown (Unresolved_value value)
| Wrong ->
Misc.fatal_errorf "Wrong approximation for [Project_closure] \
when being used as a [constant_defining_value]: %a"
(* First declare an empty version of the symbols *)
let env =
List.fold_left (fun env (symbol, _) ->
- E.add_symbol env symbol (A.value_unresolved symbol))
+ E.add_symbol env symbol (A.value_unresolved (Symbol symbol)))
env defs
in
let rec loop times env =
A.value_closure value_set_of_closures closure_id
| Unresolved sym -> A.value_unresolved sym
| Unknown -> A.value_unknown Other
- | Unknown_because_of_unresolved_symbol sym ->
- A.value_unknown (Unresolved_symbol sym)
+ | Unknown_because_of_unresolved_value value ->
+ A.value_unknown (Unresolved_value value)
| Wrong ->
Misc.fatal_errorf "Wrong approximation for [Project_closure] \
when being used as a [constant_defining_value]: %a"
| Pfield _ -> 1
| Psetfield (_, isptr, init) ->
begin match init with
- | Initialization -> 1 (* never causes a write barrier hit *)
- | Assignment ->
+ | Root_initialization -> 1 (* never causes a write barrier hit *)
+ | Assignment | Heap_initialization ->
match isptr with
| Pointer -> 4
| Immediate -> 1
| T.Never_inline -> assert false
| T.Can_inline_if_no_larger_than threshold -> threshold
in
- Don't_try_it (S.Not_inlined.Function_obviously_too_large threshold)
+ Don't_try_it (S.Not_inlined.Above_threshold threshold)
else if not (toplevel && branch_depth = 0)
&& A.all_not_useful (E.find_list_exn env args) then
(* When all of the arguments to the function being inlined are unknown,
should already have been simplified (inside its declaration), so
we also expect no gain from the code below that permits inlining
inside the body. *)
- Don't_try_it S.Not_inlined.Unspecialised
+ Don't_try_it S.Not_inlined.No_useful_approximations
else begin
(* There are useful approximations, so we should simplify. *)
Try_it
| T.Never_inline -> assert false
| T.Can_inline_if_no_larger_than threshold -> threshold
in
- Don't_try_it (S.Not_specialised.Function_obviously_too_large threshold)
+ Don't_try_it (S.Not_specialised.Above_threshold threshold)
else if not (Var_within_closure.Map.is_empty (Lazy.force bound_vars)) then
Don't_try_it S.Not_specialised.Not_closed
else if not (Lazy.force recursive) then
module Not_inlined = struct
type t =
| Classic_mode
- | Function_obviously_too_large of int
+ | Above_threshold of int
| Annotation
- | Unspecialised
+ | No_useful_approximations
| Unrolling_depth_exceeded
| Self_call
| Without_subfunctions of Wsb.t
| Classic_mode ->
Format.pp_print_text ppf
"This function was prevented from inlining by `-Oclassic'."
- | Function_obviously_too_large size ->
+ | Above_threshold size ->
Format.pp_print_text ppf
"This function was not inlined because \
- it was obviously too large";
+ it was larger than the current size threshold";
Format.fprintf ppf "(%i)" size
| Annotation ->
Format.pp_print_text ppf
"This function was not inlined because \
of an annotation."
- | Unspecialised ->
+ | No_useful_approximations ->
Format.pp_print_text ppf
"This function was not inlined because \
- its parameters could not be specialised."
+ there was no useful information about any of its parameters, \
+ and it was not particularly small."
| Unrolling_depth_exceeded ->
Format.pp_print_text ppf
"This function was not inlined because \
let calculation ~depth ppf = function
| Classic_mode
- | Function_obviously_too_large _
+ | Above_threshold _
| Annotation
- | Unspecialised
+ | No_useful_approximations
| Unrolling_depth_exceeded
| Self_call -> ()
| Without_subfunctions wsb ->
module Not_specialised = struct
type t =
| Classic_mode
- | Function_obviously_too_large of int
+ | Above_threshold of int
| Annotation
| Not_recursive
| Not_closed
Format.pp_print_text ppf
"This function was prevented from specialising by \
`-Oclassic'."
- | Function_obviously_too_large size ->
+ | Above_threshold size ->
Format.pp_print_text ppf
"This function was not specialised because \
- it was obviously too large";
+ it was larger than the current size threshold";
Format.fprintf ppf "(%i)" size
| Annotation ->
Format.pp_print_text ppf
let calculation ~depth ppf = function
| Classic_mode
- | Function_obviously_too_large _
+ | Above_threshold _
| Annotation
| Not_recursive
| Not_closed
module Not_inlined : sig
type t =
| Classic_mode
- | Function_obviously_too_large of int
+ | Above_threshold of int
| Annotation
- | Unspecialised
+ | No_useful_approximations
| Unrolling_depth_exceeded
| Self_call
| Without_subfunctions of
module Not_specialised : sig
type t =
| Classic_mode
- | Function_obviously_too_large of int
+ | Above_threshold of int
| Annotation
| Not_recursive
| Not_closed
var_to_definition_tbl
var
in
- match resolved with
- | Symbol s -> Symbol s
- | Const c -> Const c)
+ match named, resolved with
+ | Symbol s1, Symbol s2 ->
+ assert (s1 == s2); (* physical equality for speed *)
+ named;
+ | Const c1, Const c2 ->
+ assert (c1 == c2);
+ named
+ | _, Symbol s -> Symbol s
+ | _, Const c -> Const c)
in
(* This is safe because we only [replace] the current key during
iteration (cf. https://github.com/ocaml/ocaml/pull/337) *)
+-+ ("Inline_and_simplify",
Inline_and_simplify.run ~never_inline:false ~backend
~prefixname ~round)
- +-+ ("Ref_to_variables",
- Ref_to_variables.eliminate_ref)
+-+ ("Remove_unused_closure_vars 2",
Remove_unused_closure_vars.remove_unused_closure_variables
~remove_direct_call_surrogates:false)
+ +-+ ("Ref_to_variables",
+ Ref_to_variables.eliminate_ref)
+-+ ("Initialize_symbol_to_let_symbol",
Initialize_symbol_to_let_symbol.run)
in
Remove_unused_closure_vars.remove_unused_closure_variables
~remove_direct_call_surrogates:false)
+-+ ("lift_lets 3", Lift_code.lift_lets)
- +-+ ("Ref_to_variables",
- Ref_to_variables.eliminate_ref)
+-+ ("Inline_and_simplify noinline",
Inline_and_simplify.run ~never_inline:true ~backend
~prefixname ~round)
+-+ ("Remove_unused_closure_vars 3",
Remove_unused_closure_vars.remove_unused_closure_variables
~remove_direct_call_surrogates:false)
+ +-+ ("Ref_to_variables",
+ Ref_to_variables.eliminate_ref)
+-+ ("Initialize_symbol_to_let_symbol",
Initialize_symbol_to_let_symbol.run)
|> loop
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Pierre Chambart, OCamlPro *)
-(* Mark Shinwell and Leo White, Jane Street Europe *)
-(* *)
-(* Copyright 2013--2016 OCamlPro SAS *)
-(* Copyright 2014--2016 Jane Street Group LLC *)
-(* *)
-(* All rights reserved. This file is distributed under the terms of *)
-(* the GNU Lesser General Public License version 2.1, with the *)
-(* special exception on linking described in the file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-[@@@ocaml.warning "+a-4-9-30-40-41-42"]
-
-type effects = No_effects | Only_generative_effects | Arbitrary_effects
-type coeffects = No_coeffects | Has_coeffects
-
-let for_primitive (prim : Lambda.primitive) =
- match prim with
- | Pignore | Pidentity | Pbytes_to_string | Pbytes_of_string ->
- No_effects, No_coeffects
- | Pmakeblock _
- | Pmakearray (_, Mutable) -> Only_generative_effects, No_coeffects
- | Pmakearray (_, Immutable) -> No_effects, No_coeffects
- | Pduparray (_, Immutable) ->
- No_effects, No_coeffects (* Pduparray (_, Immutable) is allowed only on
- immutable arrays. *)
- | Pduparray (_, Mutable) | Pduprecord _ ->
- Only_generative_effects, Has_coeffects
- | Pccall { prim_name =
- ( "caml_format_float" | "caml_format_int" | "caml_int32_format"
- | "caml_nativeint_format" | "caml_int64_format" ) } ->
- No_effects, No_coeffects
- | Plazyforce
- | Pccall _ -> Arbitrary_effects, Has_coeffects
- | Praise _ -> Arbitrary_effects, No_coeffects
- | Pnot
- | Pnegint
- | Paddint
- | Psubint
- | Pmulint
- | Pandint
- | Porint
- | Pxorint
- | Plslint
- | Plsrint
- | Pasrint
- | Pintcomp _ -> No_effects, No_coeffects
- | Pdivbint { is_safe = Unsafe }
- | Pmodbint { is_safe = Unsafe }
- | Pdivint Unsafe
- | Pmodint Unsafe ->
- No_effects, No_coeffects (* Will not raise [Division_by_zero]. *)
- | Pdivbint { is_safe = Safe }
- | Pmodbint { is_safe = Safe }
- | Pdivint Safe
- | Pmodint Safe ->
- Arbitrary_effects, No_coeffects
- | Poffsetint _ -> No_effects, No_coeffects
- | Poffsetref _ -> Arbitrary_effects, Has_coeffects
- | Pintoffloat
- | Pfloatofint
- | Pnegfloat
- | Pabsfloat
- | Paddfloat
- | Psubfloat
- | Pmulfloat
- | Pdivfloat
- | Pfloatcomp _ -> No_effects, No_coeffects
- | Pstringlength | Pbyteslength
- | Parraylength _ ->
- No_effects, Has_coeffects (* That old chestnut: [Obj.truncate]. *)
- | Pisint
- | Pisout
- | Pbittest
- | Pbintofint _
- | Pintofbint _
- | Pcvtbint _
- | Pnegbint _
- | Paddbint _
- | Psubbint _
- | Pmulbint _
- | Pandbint _
- | Porbint _
- | Pxorbint _
- | Plslbint _
- | Plsrbint _
- | Pasrbint _
- | Pbintcomp _ -> No_effects, No_coeffects
- | Pbigarraydim _ ->
- No_effects, Has_coeffects (* Some people resize bigarrays in place. *)
- | Pfield _
- | Pfloatfield _
- | Pgetglobal _
- | Parrayrefu _
- | Pstringrefu
- | Pbytesrefu
- | Pstring_load_16 true
- | Pstring_load_32 true
- | Pstring_load_64 true
- | Pbigarrayref (true, _, _, _)
- | Pbigstring_load_16 true
- | Pbigstring_load_32 true
- | Pbigstring_load_64 true ->
- No_effects, Has_coeffects
- | Parrayrefs _
- | Pstringrefs
- | Pbytesrefs
- | Pstring_load_16 false
- | Pstring_load_32 false
- | Pstring_load_64 false
- | Pbigarrayref (false, _, _, _)
- | Pbigstring_load_16 false
- | Pbigstring_load_32 false
- | Pbigstring_load_64 false ->
- (* May trigger a bounds check exception. *)
- Arbitrary_effects, Has_coeffects
- | Psetfield _
- | Psetfloatfield _
- | Psetglobal _
- | Parraysetu _
- | Parraysets _
- | Pbytessetu
- | Pbytessets
- | Pstring_set_16 _
- | Pstring_set_32 _
- | Pstring_set_64 _
- | Pbigarrayset _
- | Pbigstring_set_16 _
- | Pbigstring_set_32 _
- | Pbigstring_set_64 _ ->
- (* Whether or not some of these are "unsafe" is irrelevant; they always
- have an effect. *)
- Arbitrary_effects, No_coeffects
- | Pctconst _ -> No_effects, No_coeffects
- | Pbswap16
- | Pbbswap _ -> No_effects, No_coeffects
- | Pint_as_pointer -> No_effects, No_coeffects
- | Popaque -> Arbitrary_effects, Has_coeffects
- | Ploc _ ->
- Misc.fatal_error "[Ploc] should have been eliminated by [Translcore]"
- | 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
+++ /dev/null
-(**************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* Pierre Chambart, OCamlPro *)
-(* Mark Shinwell and Leo White, Jane Street Europe *)
-(* *)
-(* Copyright 2013--2016 OCamlPro SAS *)
-(* Copyright 2014--2016 Jane Street Group LLC *)
-(* *)
-(* All rights reserved. This file is distributed under the terms of *)
-(* the GNU Lesser General Public License version 2.1, with the *)
-(* special exception on linking described in the file LICENSE. *)
-(* *)
-(**************************************************************************)
-
-[@@@ocaml.warning "+a-4-9-30-40-41-42"]
-
-(** Description of the semantics of primitives, to be used for optimization
- purposes.
-
- "No effects" means that the primitive does not change the observable state
- of the world. For example, it must not write to any mutable storage,
- call arbitrary external functions or change control flow (e.g. by raising
- an exception). Note that allocation is not "No effects" (see below).
-
- It is assumed in the compiler that applications of primitives with no
- effects, whose results are not used, may be eliminated. It is further
- assumed that applications of primitives with no effects may be
- duplicated (and thus possibly executed more than once).
-
- (Exceptions arising from allocation points, for example "out of memory" or
- exceptions propagated from finalizers or signal handlers, are treated as
- "effects out of the ether" and thus ignored for our determination here
- of effectfulness. The same goes for floating point operations that may
- cause hardware traps on some platforms.)
-
- "Only generative effects" means that a primitive does not change the
- observable state of the world save for possibly affecting the state of
- the garbage collector by performing an allocation. Applications of
- primitives that only have generative effects and whose results are unused
- may be eliminated by the compiler. However, unlike "No effects"
- primitives, such applications will never be eligible for duplication.
-
- "Arbitrary effects" covers all other primitives.
-
- "No coeffects" means that the primitive does not observe the effects (in
- the sense described above) of other expressions. For example, it must not
- read from any mutable storage or call arbitrary external functions.
-
- It is assumed in the compiler that, subject to data dependencies,
- expressions with neither effects nor coeffects may be reordered with
- respect to other expressions.
-*)
-
-type effects = No_effects | Only_generative_effects | Arbitrary_effects
-type coeffects = No_coeffects | Has_coeffects
-
-(** Describe the semantics of a primitive. This does not take into account of
- the (non-)(co)effectfulness of the arguments in a primitive application.
- To determine whether such an application is (co)effectful, the arguments
- must also be analysed. *)
-val for_primitive
- : Lambda.primitive
- -> effects * coeffects
-
-type return_type =
- | Float
- | Other
-
-val return_type_of_primitive : Lambda.primitive -> return_type
size : int;
}
+type unresolved_value =
+ | Set_of_closures_id of Set_of_closures_id.t
+ | Symbol of Symbol.t
+
type unknown_because_of =
- | Unresolved_symbol of Symbol.t
+ | Unresolved_value of unresolved_value
| Other
type t = {
| Value_bottom
| Value_extern of Export_id.t
| Value_symbol of Symbol.t
- | Value_unresolved of Symbol.t (* No description was found for this symbol *)
+ | Value_unresolved of unresolved_value
+ (* No description was found for this value *)
and value_closure = {
set_of_closures : t;
(Variable.Map.print Variable.Set.print) (Lazy.force invariant_params)
Freshening.Project_var.print freshening
+let print_unresolved_value ppf = function
+ | Set_of_closures_id set ->
+ Format.fprintf ppf "Set_of_closures_id %a" Set_of_closures_id.print set
+ | Symbol symbol ->
+ Format.fprintf ppf "Symbol %a" Symbol.print symbol
+
let rec print_descr ppf = function
| Value_int i -> Format.pp_print_int ppf i
| Value_char c -> Format.fprintf ppf "%c" c
Format.fprintf ppf "[%i:@ @[<1>%a@]]" (Tag.to_int tag) p fields
| Value_unknown reason ->
begin match reason with
- | Unresolved_symbol symbol ->
- Format.fprintf ppf "?(due to unresolved symbol '%a')" Symbol.print symbol
+ | Unresolved_value value ->
+ Format.fprintf ppf "?(due to unresolved %a)" print_unresolved_value value
| Other -> Format.fprintf ppf "?"
end;
| Value_bottom -> Format.fprintf ppf "bottom"
print set_of_closures
| Value_set_of_closures set_of_closures ->
print_value_set_of_closures ppf set_of_closures
- | Value_unresolved sym ->
- Format.fprintf ppf "(unresolved %a)" Symbol.print sym
+ | Value_unresolved value ->
+ Format.fprintf ppf "(unresolved %a)" print_unresolved_value value
| Value_float (Some f) -> Format.pp_print_float ppf f
| Value_float None -> Format.pp_print_string ppf "float"
| Value_string { contents; size } -> begin
let value_symbol sym =
{ (approx (Value_symbol sym)) with symbol = Some (sym, None) }
let value_bottom = approx Value_bottom
-let value_unresolved sym = approx (Value_unresolved sym)
+let value_unresolved value = approx (Value_unresolved value)
let value_string size contents = approx (Value_string {size; contents })
let value_mutable_float_array ~size =
Ok (value_unknown Other)
| Value_unknown reason ->
Ok (value_unknown reason)
- | Value_unresolved sym ->
+ | Value_unresolved value ->
(* We don't know anything, but we must remember that it comes
from another compilation unit in case it contains a closure. *)
- Ok (value_unresolved sym)
+ Ok (value_unknown (Unresolved_value value))
type checked_approx_for_block =
| Wrong
type checked_approx_for_set_of_closures =
| Wrong
- | Unresolved of Symbol.t
+ | Unresolved of unresolved_value
| Unknown
- | Unknown_because_of_unresolved_symbol of Symbol.t
+ | Unknown_because_of_unresolved_value of unresolved_value
| Ok of Variable.t option * value_set_of_closures
let check_approx_for_set_of_closures t : checked_approx_for_set_of_closures =
match t.descr with
- | Value_unresolved symbol -> Unresolved symbol
- | Value_unknown (Unresolved_symbol symbol) ->
- Unknown_because_of_unresolved_symbol symbol
+ | Value_unresolved value -> Unresolved value
+ | Value_unknown (Unresolved_value value) ->
+ Unknown_because_of_unresolved_value value
| Value_set_of_closures value_set_of_closures ->
(* Note that [var] might be [None]; we might be reaching the set of
closures via approximations only, with the variable originally bound
match check_approx_for_set_of_closures t with
| Ok (var, value_set_of_closures) -> Ok (var, value_set_of_closures)
| Wrong | Unresolved _
- | Unknown | Unknown_because_of_unresolved_symbol _ -> Wrong
+ | Unknown | Unknown_because_of_unresolved_value _ -> Wrong
type checked_approx_for_closure_allowing_unresolved =
| Wrong
- | Unresolved of Symbol.t
+ | Unresolved of unresolved_value
| Unknown
- | Unknown_because_of_unresolved_symbol of Symbol.t
+ | Unknown_because_of_unresolved_value of unresolved_value
| Ok of value_closure * Variable.t option
* Symbol.t option * value_set_of_closures
| Value_symbol _ ->
Wrong
end
- | Value_unknown (Unresolved_symbol symbol) ->
- Unknown_because_of_unresolved_symbol symbol
+ | Value_unknown (Unresolved_value value) ->
+ Unknown_because_of_unresolved_value value
| Value_unresolved symbol -> Unresolved symbol
| Value_set_of_closures _ | Value_block _ | Value_int _ | Value_char _
| Value_constptr _ | Value_float _ | Value_boxed_int _
value_set_of_closures) ->
Ok (value_closure, set_of_closures_var, set_of_closures_symbol,
value_set_of_closures)
- | Wrong | Unknown | Unresolved _ | Unknown_because_of_unresolved_symbol _ ->
+ | Wrong | Unknown | Unresolved _ | Unknown_because_of_unresolved_value _ ->
Wrong
let approx_for_bound_var value_set_of_closures var =
size : int;
}
+type unresolved_value =
+ | Set_of_closures_id of Set_of_closures_id.t
+ | Symbol of Symbol.t
+
type unknown_because_of =
- | Unresolved_symbol of Symbol.t
+ | Unresolved_value of unresolved_value
| Other
(** A value of type [t] corresponds to an "approximation" of the result of
| Value_bottom
| Value_extern of Export_id.t
| Value_symbol of Symbol.t
- | Value_unresolved of Symbol.t (* No description was found for this symbol *)
+ | Value_unresolved of unresolved_value
+ (* No description was found for this value *)
and value_closure = {
set_of_closures : t;
val value_extern : Export_id.t -> t
val value_symbol : Symbol.t -> t
val value_bottom : t
-val value_unresolved : Symbol.t -> t
+val value_unresolved : unresolved_value -> t
(** Construct a closure approximation given the approximation of the
corresponding set of closures and the closure ID of the closure to
type checked_approx_for_set_of_closures =
| Wrong
- | Unresolved of Symbol.t
+ | Unresolved of unresolved_value
| Unknown
- | Unknown_because_of_unresolved_symbol of Symbol.t
+ | Unknown_because_of_unresolved_value of unresolved_value
(* In the [Ok] case, there may not be a variable associated with the set of
closures; it might be out of scope. *)
| Ok of Variable.t option * value_set_of_closures
type checked_approx_for_closure_allowing_unresolved =
| Wrong
- | Unresolved of Symbol.t
+ | Unresolved of unresolved_value
| Unknown
- | Unknown_because_of_unresolved_symbol of Symbol.t
+ | Unknown_because_of_unresolved_value of unresolved_value
| Ok of value_closure * Variable.t option
* Symbol.t option * value_set_of_closures
+generators/odoc_literate.cmo : odoc_info.cmi odoc_html.cmo odoc_gen.cmi \
+ odoc_args.cmi
+generators/odoc_literate.cmx : odoc_info.cmx odoc_html.cmx odoc_gen.cmx \
+ odoc_args.cmx
+generators/odoc_todo.cmo : odoc_module.cmo odoc_info.cmi odoc_html.cmo \
+ odoc_gen.cmi odoc_args.cmi
+generators/odoc_todo.cmx : odoc_module.cmx odoc_info.cmx odoc_html.cmx \
+ odoc_gen.cmx odoc_args.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 \
../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
+ odoc_class.cmo ../utils/misc.cmi
odoc_module.cmx : ../typing/types.cmx odoc_value.cmx odoc_types.cmx \
odoc_type.cmx odoc_name.cmx odoc_extension.cmx odoc_exception.cmx \
- odoc_class.cmx
+ odoc_class.cmx ../utils/misc.cmx
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 \
#* *
#**************************************************************************
-include ../config/Makefile
-CAMLRUN ?= ../boot/ocamlrun
-CAMLYACC ?= ../boot/ocamlyacc
-
-# Various commands and dir
-##########################
-ROOTDIR = ..
-OCAMLC = $(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib
-OCAMLOPT = $(CAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib -I $(ROOTDIR)/stdlib
-OCAMLDEP = $(CAMLRUN) $(ROOTDIR)/tools/ocamldep
-OCAMLLEX = $(CAMLRUN) $(ROOTDIR)/boot/ocamllex
-OCAMLLIB = $(LIBDIR)
-OCAMLBIN = $(BINDIR)
-
-OCAMLPP=-pp './remove_DEBUG'
+ROOTDIR = ..
+
+include $(ROOTDIR)/config/Makefile
+OCAMLRUN ?= $(ROOTDIR)/boot/ocamlrun
+OCAMLYACC ?= $(ROOTDIR)/boot/ocamlyacc
+
+STDLIBFLAGS = -nostdlib -I $(ROOTDIR)/stdlib
+OCAMLC = $(OCAMLRUN) $(ROOTDIR)/ocamlc $(STDLIBFLAGS)
+ifeq "$(UNIX_OR_WIN32)" "unix"
+OCAMLOPT = $(OCAMLRUN) $(ROOTDIR)/ocamlopt $(STDLIBFLAGS)
+else # Windows
+ ifeq "$(wildcard $(ROOTDIR)/flexdll/Makefile)" ""
+ FLEXLINK_ENV=
+ else
+ FLEXLINK_ENV=OCAML_FLEXLINK="$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/flexdll/flexlink.exe"
+ endif
+ OCAMLOPT = $(FLEXLINK_ENV) $(OCAMLRUN) $(ROOTDIR)/ocamlopt $(STDLIBFLAGS)
+endif
+OCAMLDEP = $(OCAMLRUN) $(ROOTDIR)/tools/ocamldep -slash
+OCAMLLEX = $(OCAMLRUN) $(ROOTDIR)/boot/ocamllex
+# TODO: figure out whether the DEBUG lines the following preprocessor removes
+# are actually useful.
+# If they are not, then the preprocessor logic (including the
+# remove_DEBUG script and the debug target) could be removed.
+# If they are, it may be better to be able to enable them at run-time
+# rather than compile-time, e.g. through a -debug command-line option.
+# In the following line, "sh" is useful under Windows. Without it,
+# the ./remove_DEBUG command would be executed by cmd.exe which would not
+# know how to handle it.
+OCAMLPP=-pp 'sh ./remove_DEBUG'
# For installation
##############
+
MKDIR=mkdir -p
-CP=cp -f
-OCAMLDOC=./ocamldoc
-ifeq "$(TARGET)" "$(HOST)"
- ifeq "$(SUPPORTS_SHARED_LIBRARIES)" "true"
- OCAMLDOC_RUN=$(CAMLRUN) -I ../otherlibs/unix -I ../otherlibs/str $(OCAMLDOC)
+CP=cp
+OCAMLDOC=ocamldoc
+
+# TODO: clarify whether the following really needs to be that complicated
+ifeq "$(UNIX_OR_WIN32)" "unix"
+ ifeq "$(TARGET)" "$(HOST)"
+ ifeq "$(SUPPORTS_SHARED_LIBRARIES)" "true"
+ OCAMLDOC_RUN=$(OCAMLRUN) -I $(ROOTDIR)/otherlibs/$(UNIXLIB) -I $(ROOTDIR)/otherlibs/str ./$(OCAMLDOC)
+ else
+ OCAMLDOC_RUN=./$(OCAMLDOC)
+ endif
else
- OCAMLDOC_RUN=$(OCAMLDOC)
+ OCAMLDOC_RUN=$(OCAMLRUN) ./$(OCAMLDOC)
endif
-else
- OCAMLDOC_RUN=$(CAMLRUN) $(OCAMLDOC)
+else # Windows
+ OCAMLDOC_RUN = CAML_LD_LIBRARY_PATH="../otherlibs/win32unix;../otherlibs/str" $(OCAMLRUN) ./$(OCAMLDOC)
endif
+
OCAMLDOC_OPT=$(OCAMLDOC).opt
OCAMLDOC_LIBCMA=odoc_info.cma
OCAMLDOC_LIBCMI=odoc_info.cmi
OCAMLDOC_LIBCMXA=odoc_info.cmxa
OCAMLDOC_LIBA=odoc_info.$(A)
-INSTALL_LIBDIR=$(DESTDIR)$(OCAMLLIB)/ocamldoc
-INSTALL_CUSTOMDIR=$(INSTALL_LIBDIR)/custom
-INSTALL_BINDIR=$(DESTDIR)$(OCAMLBIN)
+
+INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)/ocamldoc
+
+INSTALL_BINDIR=$(DESTDIR)$(BINDIR)
+
#MANO: man ocamldoc
INSTALL_MANODIR=$(DESTDIR)$(MANDIR)/man3
INSTALL_MLIS=odoc_info.mli
INSTALL_CMIS=$(INSTALL_MLIS:.mli=.cmi)
+INSTALL_CMTS=$(INSTALL_MLIS:.mli=.cmt) $(INSTALL_MLIS:.mli=.cmti)
ODOC_TEST=odoc_test.cmo
-
GENERATORS_CMOS= \
- generators/odoc_todo.cmo \
- generators/odoc_literate.cmo
-true = $(GENERATORS_CMOS:.cmo=.cmxs)
-false =
-GENERATORS_CMXS := $($(NATDYNLINK))
-
+ generators/odoc_todo.cmo \
+ generators/odoc_literate.cmo
+ifeq "$(NATDYNLINK)" "true"
+GENERATORS_CMXS = $(GENERATORS_CMOS:.cmo=.cmxs)
+else
+GENERATORS_CMXS =
+endif
# Compilation
#############
-OCAMLSRCDIR=..
-INCLUDES_DEP=-I $(OCAMLSRCDIR)/parsing \
- -I $(OCAMLSRCDIR)/utils \
- -I $(OCAMLSRCDIR)/typing \
- -I $(OCAMLSRCDIR)/driver \
- -I $(OCAMLSRCDIR)/bytecomp \
- -I $(OCAMLSRCDIR)/toplevel/
-
-INCLUDES_NODEP= -I $(OCAMLSRCDIR)/stdlib \
- -I $(OCAMLSRCDIR)/otherlibs/str \
- -I $(OCAMLSRCDIR)/otherlibs/dynlink \
- -I $(OCAMLSRCDIR)/otherlibs/$(UNIXLIB) \
- -I $(OCAMLSRCDIR)/otherlibs/num \
- -I $(OCAMLSRCDIR)/otherlibs/$(GRAPHLIB)
+
+INCLUDES_DEP=\
+ -I $(ROOTDIR)/parsing \
+ -I $(ROOTDIR)/utils \
+ -I $(ROOTDIR)/typing \
+ -I $(ROOTDIR)/driver \
+ -I $(ROOTDIR)/bytecomp \
+ -I $(ROOTDIR)/toplevel
+
+INCLUDES_NODEP=\
+ -I $(ROOTDIR)/stdlib \
+ -I $(ROOTDIR)/compilerlibs \
+ -I $(ROOTDIR)/otherlibs/str \
+ -I $(ROOTDIR)/otherlibs/dynlink \
+ -I $(ROOTDIR)/otherlibs/$(UNIXLIB) \
+ -I $(ROOTDIR)/otherlibs/num \
+ -I $(ROOTDIR)/otherlibs/$(GRAPHLIB)
INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP)
-COMPFLAGS=$(INCLUDES) -absname -w +a-4-9-41-42-44-45-48 -warn-error A -safe-string -strict-sequence -strict-formats
+COMPFLAGS=$(INCLUDES) -absname -w +a-4-9-41-42-44-45-48 -warn-error A -safe-string -strict-sequence -strict-formats -bin-annot
LINKFLAGS=$(INCLUDES) -nostdlib
-CMOFILES= odoc_config.cmo \
- odoc_messages.cmo\
- odoc_global.cmo\
- odoc_types.cmo\
- odoc_misc.cmo\
- odoc_text_parser.cmo\
- odoc_text_lexer.cmo\
- odoc_text.cmo\
- odoc_name.cmo\
- odoc_parameter.cmo\
- odoc_value.cmo\
- odoc_type.cmo\
- odoc_extension.cmo\
- odoc_exception.cmo\
- odoc_class.cmo\
- odoc_module.cmo\
- odoc_print.cmo \
- odoc_str.cmo\
- odoc_comments_global.cmo\
- odoc_parser.cmo\
- odoc_lexer.cmo\
- odoc_see_lexer.cmo\
- odoc_env.cmo\
- odoc_merge.cmo\
- odoc_sig.cmo\
- odoc_ast.cmo\
- odoc_control.cmo\
- odoc_inherit.cmo\
- odoc_search.cmo\
- odoc_scan.cmo\
- odoc_cross.cmo\
- odoc_comments.cmo\
- odoc_dep.cmo\
- odoc_analyse.cmo\
- odoc_info.cmo
-
-
-CMXFILES= $(CMOFILES:.cmo=.cmx)
-CMIFILES= $(CMOFILES:.cmo=.cmi)
-
-EXECMOFILES=$(CMOFILES) \
- odoc_dag2html.cmo \
- odoc_to_text.cmo \
- odoc_ocamlhtml.cmo \
- odoc_html.cmo \
- odoc_man.cmo \
- odoc_latex_style.cmo \
- odoc_latex.cmo \
- odoc_texi.cmo \
- odoc_dot.cmo \
- odoc_gen.cmo \
- odoc_args.cmo \
- odoc.cmo
-
-EXECMXFILES= $(EXECMOFILES:.cmo=.cmx)
-EXECMIFILES= $(EXECMOFILES:.cmo=.cmi)
-
-LIBCMOFILES=$(CMOFILES)
-LIBCMXFILES= $(LIBCMOFILES:.cmo=.cmx)
-LIBCMIFILES= $(LIBCMOFILES:.cmo=.cmi)
-
-STDLIB_MLIS=../stdlib/*.mli \
+CMOFILES=\
+ odoc_config.cmo \
+ odoc_messages.cmo \
+ odoc_global.cmo \
+ odoc_types.cmo \
+ odoc_misc.cmo \
+ odoc_text_parser.cmo \
+ odoc_text_lexer.cmo \
+ odoc_text.cmo \
+ odoc_name.cmo \
+ odoc_parameter.cmo \
+ odoc_value.cmo \
+ odoc_type.cmo \
+ odoc_extension.cmo \
+ odoc_exception.cmo \
+ odoc_class.cmo \
+ odoc_module.cmo \
+ odoc_print.cmo \
+ odoc_str.cmo \
+ odoc_comments_global.cmo \
+ odoc_parser.cmo \
+ odoc_lexer.cmo \
+ odoc_see_lexer.cmo \
+ odoc_env.cmo \
+ odoc_merge.cmo \
+ odoc_sig.cmo \
+ odoc_ast.cmo \
+ odoc_control.cmo \
+ odoc_inherit.cmo \
+ odoc_search.cmo \
+ odoc_scan.cmo \
+ odoc_cross.cmo \
+ odoc_comments.cmo \
+ odoc_dep.cmo \
+ odoc_analyse.cmo \
+ odoc_info.cmo
+
+CMXFILES = $(CMOFILES:.cmo=.cmx)
+CMIFILES = $(CMOFILES:.cmo=.cmi)
+
+EXECMOFILES=\
+ $(CMOFILES) \
+ odoc_dag2html.cmo \
+ odoc_to_text.cmo \
+ odoc_ocamlhtml.cmo \
+ odoc_html.cmo \
+ odoc_man.cmo \
+ odoc_latex_style.cmo \
+ odoc_latex.cmo \
+ odoc_texi.cmo \
+ odoc_dot.cmo \
+ odoc_gen.cmo \
+ odoc_args.cmo \
+ odoc.cmo
+
+EXECMXFILES = $(EXECMOFILES:.cmo=.cmx)
+EXECMIFILES = $(EXECMOFILES:.cmo=.cmi)
+
+LIBCMOFILES = $(CMOFILES)
+LIBCMXFILES = $(LIBCMOFILES:.cmo=.cmx)
+LIBCMIFILES = $(LIBCMOFILES:.cmo=.cmi)
+
+STDLIB_MLIS=\
+ ../stdlib/*.mli \
../parsing/*.mli \
- ../otherlibs/$(UNIXLIB)/unix.mli \
- ../otherlibs/str/str.mli \
- ../otherlibs/bigarray/bigarray.mli \
- ../otherlibs/num/num.mli
+ ../otherlibs/$(UNIXLIB)/unix.mli \
+ ../otherlibs/str/str.mli \
+ ../otherlibs/bigarray/bigarray.mli \
+ ../otherlibs/num/num.mli
-all:
- $(MAKE) exe
- $(MAKE) lib
- $(MAKE) generators
- $(MAKE) manpages
+.PHONY: all
+all: lib exe generators manpages
+manpages: generators
+
+.PHONY: exe
exe: $(OCAMLDOC)
+
+.PHONY: lib
lib: $(OCAMLDOC_LIBCMA) $(OCAMLDOC_LIBCMI) $(ODOC_TEST)
+
+.PHONY: generators
generators: $(GENERATORS_CMOS)
-opt.opt:
- $(MAKE) exeopt
- $(MAKE) libopt
- $(MAKE) generatorsopt
+.PHONY: opt.opt
+opt.opt: exeopt libopt generatorsopt
+.PHONY: exeopt
exeopt: $(OCAMLDOC_OPT)
+
+.PHONY: libopt
libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI)
+
+.PHONY: generatorsopt
generatorsopt: $(GENERATORS_CMXS)
+# TODO: the following debug target could be replaced by a DEBUG variable
+.PHONY: debug
debug:
$(MAKE) OCAMLPP=""
+OCAMLDOC_LIBRARIES = unix str dynlink ocamlcommon
+
+OCAMLDOC_BCLIBRARIES = $(OCAMLDOC_LIBRARIES:%=%.cma)
+OCAMLDOC_NCLIBRARIES = $(OCAMLDOC_LIBRARIES:%=%.cmxa)
+
$(OCAMLDOC): $(EXECMOFILES)
- $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma \
- $(OCAMLSRCDIR)/compilerlibs/ocamlcommon.cma \
- $(LINKFLAGS) $(EXECMOFILES)
+ $(OCAMLC) -o $@ -linkall $(LINKFLAGS) $(OCAMLDOC_BCLIBRARIES) $^
+
$(OCAMLDOC_OPT): $(EXECMXFILES)
- $(OCAMLOPT) -o $@ -linkall unix.cmxa str.cmxa dynlink.cmxa \
- $(OCAMLSRCDIR)/compilerlibs/ocamlcommon.cmxa \
- $(LINKFLAGS) $(EXECMXFILES)
+ $(OCAMLOPT) -o $@ -linkall $(LINKFLAGS) $(OCAMLDOC_NCLIBRARIES) $^
$(OCAMLDOC_LIBCMA): $(LIBCMOFILES)
- $(OCAMLC) -a -o $@ $(LINKFLAGS) \
- $(LIBCMOFILES)
+ $(OCAMLC) -a -o $@ $(LINKFLAGS) $^
+
$(OCAMLDOC_LIBCMXA): $(LIBCMXFILES)
- $(OCAMLOPT) -a -o $@ $(LINKFLAGS) \
- $(LIBCMXFILES)
+ $(OCAMLOPT) -a -o $@ $(LINKFLAGS) $^
+.PHONY: manpages
manpages: stdlib_man/Pervasives.3o
+
+.PHONY: html_doc
html_doc: stdlib_html/Pervasives.html
-dot: $(EXECMOFILES)
- $(OCAMLDOC_RUN) -dot -dot-reduce -o ocamldoc.dot $(INCLUDES) \
- odoc*.ml
+.PHONY: dot
+dot: ocamldoc.dot
+
+ocamldoc.dot: $(EXECMOFILES)
+ $(OCAMLDOC_RUN) -dot -dot-reduce -o $@ $(INCLUDES) odoc*.ml
# Parsers and lexers dependencies :
###################################
$(OCAMLLEX) $<
.mly.ml:
- $(CAMLYACC) -v $<
+ $(OCAMLYACC) -v $<
.mly.mli:
- $(CAMLYACC) -v $<
+ $(OCAMLYACC) -v $<
# Installation targets
######################
-install: dummy
- if test -d "$(INSTALL_BINDIR)"; then : ; else $(MKDIR) "$(INSTALL_BINDIR)"; fi
- if test -d "$(INSTALL_LIBDIR)"; then : ; else $(MKDIR) "$(INSTALL_LIBDIR)"; fi
- if test -d "$(INSTALL_CUSTOMDIR)"; then : ; else $(MKDIR) "$(INSTALL_CUSTOMDIR)"; fi
+
+# TODO: it may be good to split the following rule in several ones, e.g.
+# install-programs, install-doc, install-libs
+
+.PHONY: install
+install:
+ $(MKDIR) "$(INSTALL_BINDIR)"
+ $(MKDIR) "$(INSTALL_LIBDIR)"
+ $(MKDIR) "$(INSTALL_MANODIR)"
$(CP) $(OCAMLDOC) "$(INSTALL_BINDIR)/$(OCAMLDOC)$(EXE)"
$(CP) ocamldoc.hva *.cmi $(OCAMLDOC_LIBCMA) "$(INSTALL_LIBDIR)"
- $(CP) $(INSTALL_MLIS) $(INSTALL_CMIS) "$(INSTALL_LIBDIR)"
- if test -d "$(INSTALL_MANODIR)"; then : ; else $(MKDIR) "$(INSTALL_MANODIR)"; fi
+ $(CP) $(INSTALL_MLIS) $(INSTALL_CMIS) $(INSTALL_CMTS) "$(INSTALL_LIBDIR)"
if test -d stdlib_man; then $(CP) stdlib_man/* "$(INSTALL_MANODIR)"; else : ; fi
+# Note: at the moment, $(INSTALL_MANODIR) is created even if the doc has
+# not been built. This is not clean and should be changed.
+
+.PHONY: installopt
installopt:
if test -f $(OCAMLDOC_OPT); then $(MAKE) installopt_really ; fi
+.PHONY: installopt_really
installopt_really:
- if test -d "$(INSTALL_BINDIR)"; then : ; else $(MKDIR) "$(INSTALL_BINDIR)"; fi
- if test -d "$(INSTALL_LIBDIR)"; then : ; else $(MKDIR) "$(INSTALL_LIBDIR)"; fi
+ $(MKDIR) "$(INSTALL_BINDIR)"
+ $(MKDIR) "$(INSTALL_LIBDIR)"
$(CP) $(OCAMLDOC_OPT) "$(INSTALL_BINDIR)/$(OCAMLDOC_OPT)$(EXE)"
- $(CP) ocamldoc.hva *.cmx $(OCAMLDOC_LIBA) $(OCAMLDOC_LIBCMXA) "$(INSTALL_LIBDIR)"
- $(CP) $(INSTALL_MLIS) $(INSTALL_CMIS) "$(INSTALL_LIBDIR)"
+ $(CP) $(INSTALL_MLIS) $(INSTALL_CMIS) $(INSTALL_CMTS) "$(INSTALL_LIBDIR)"
+ $(CP) ocamldoc.hva *.cmx $(OCAMLDOC_LIBA) $(OCAMLDOC_LIBCMXA) \
+ "$(INSTALL_LIBDIR)"
+
+# TODO: also split into several rules
# Testing :
###########
-test: dummy
+
+.PHONY: test
+test:
$(MKDIR) $@
$(OCAMLDOC_RUN) -html -colorize-code -sort -d $@ $(INCLUDES) -dump $@/ocamldoc.odoc odoc*.ml odoc*.mli -v
$(MKDIR) $@-custom
-g generators/odoc_literate.cmo -g generators/odoc_todo.cmo \
-load $@/ocamldoc.odoc -v
-test_stdlib: dummy
+.PHONY: test_stdlib
+test_stdlib:
$(MKDIR) $@
$(OCAMLDOC_RUN) -html -colorize-code -sort -d $@ $(INCLUDES) -dump $@/stdlib.odoc -keep-code \
../stdlib/pervasives.ml ../stdlib/*.mli \
../otherlibs/$(UNIXLIB)/unix.mli \
../otherlibs/str/str.mli
-test_stdlib_code: dummy
+.PHONY: test_stdlib_code
+test_stdlib_code:
$(MKDIR) $@
$(OCAMLDOC_RUN) -html -colorize-code -sort -d $@ $(INCLUDES) -dump $@/stdlib.odoc -keep-code \
`ls ../stdlib/*.ml | grep -v Labels` \
../otherlibs/$(UNIXLIB)/unix.ml \
../otherlibs/str/str.ml
-test_framed: dummy
+.PHONY: test_framed
+test_framed:
$(MKDIR) $@
$(OCAMLDOC_RUN) -g odoc_fhtml.cmo -sort -colorize-code -d $@ $(INCLUDES) odoc*.ml odoc*.mli
-test_latex: dummy
+.PHONY: test_latex
+test_latex:
$(MKDIR) $@
$(OCAMLDOC_RUN) -latex -sort -o $@/test.tex -d $@ $(INCLUDES) odoc*.ml \
odoc*.mli test2.txt ../stdlib/*.mli ../otherlibs/unix/unix.mli
-test_latex_simple: dummy
+.PHONY: test_latex_simple
+test_latex_simple:
$(MKDIR) $@
$(OCAMLDOC_RUN) -latex -sort -o $@/test.tex -d $@ $(INCLUDES) \
-latextitle 6,subsection -latextitle 7,subsubection \
../otherlibs/$(UNIXLIB)/unix.mli \
../stdlib/map.mli
-test_man: dummy
+.PHONY: test_man
+test_man:
$(MKDIR) $@
$(OCAMLDOC_RUN) -man -sort -d $@ $(INCLUDES) odoc*.ml odoc*.mli
-test_texi: dummy
+.PHONY: test_texi
+test_texi:
$(MKDIR) $@
$(OCAMLDOC_RUN) -texi -sort -d $@ $(INCLUDES) odoc*.ml odoc*.mli
-stdlib_man/Pervasives.3o: $(STDLIB_MLIS)
+stdlib_man/Pervasives.3o: $(OCAMLDOC) $(STDLIB_MLIS)
$(MKDIR) stdlib_man
$(OCAMLDOC_RUN) -man -d stdlib_man $(INCLUDES) \
- -t "OCaml library" -man-mini \
- $(STDLIB_MLIS)
+ -t "OCaml library" -man-mini $(STDLIB_MLIS)
stdlib_html/Pervasives.html: $(STDLIB_MLIS)
$(MKDIR) stdlib_html
$(OCAMLDOC_RUN) -d stdlib_html -html $(INCLUDES) \
- -t "OCaml library" \
- $(STDLIB_MLIS)
+ -t "OCaml library" $^
-
-autotest_stdlib: dummy
+.PHONY: autotest_stdlib
+autotest_stdlib:
$(MKDIR) $@
$(OCAMLDOC_RUN) -g autotest/odoc_test.cmo\
$(INCLUDES) -keep-code \
# backup, clean and depend :
############################
-clean:: dummy
- @rm -f *~ \#*\#
- @rm -f $(OCAMLDOC) $(OCAMLDOC_OPT) *.cma *.cmxa *.cmo *.cmi *.cmx *.$(A) *.$(O)
- @rm -f odoc_parser.output odoc_text_parser.output
- @rm -f odoc_lexer.ml odoc_text_lexer.ml odoc_see_lexer.ml odoc_ocamlhtml.ml
- @rm -f odoc_parser.ml odoc_parser.mli odoc_text_parser.ml odoc_text_parser.mli
- @rm -rf stdlib_man
- @rm -f generators/*.cm[aiox] generators/*.$(A) generators/*.$(O) generators/*.cmx[as]
-
-depend::
- $(CAMLYACC) odoc_text_parser.mly
- $(CAMLYACC) odoc_parser.mly
+.PHONY: clean
+clean:
+ rm -f *~ \#*\#
+ rm -f $(OCAMLDOC) $(OCAMLDOC_OPT) *.cma *.cmxa *.cmo *.cmi *.cmx *.cmt *.cmti *.$(A) *.$(O)
+ rm -f odoc_parser.output odoc_text_parser.output
+ rm -f odoc_lexer.ml odoc_text_lexer.ml odoc_see_lexer.ml odoc_ocamlhtml.ml
+ rm -f odoc_parser.ml odoc_parser.mli odoc_text_parser.ml odoc_text_parser.mli
+ rm -rf stdlib_man
+ rm -f generators/*.cm[taiox] generators/*.$(A) generators/*.$(O) generators/*.cmx[as]
+
+.PHONY: depend
+depend:
+ $(OCAMLYACC) odoc_text_parser.mly
+ $(OCAMLYACC) odoc_parser.mly
$(OCAMLLEX) odoc_text_lexer.mll
$(OCAMLLEX) odoc_lexer.mll
$(OCAMLLEX) odoc_ocamlhtml.mll
$(OCAMLLEX) odoc_see_lexer.mll
- $(OCAMLDEP) $(INCLUDES_DEP) *.mll *.mly *.ml *.mli > .depend
-
-dummy:
+ $(OCAMLDEP) $(INCLUDES_DEP) *.mll *.mly *.ml *.mli generators/*.ml > .depend
include .depend
#* *
#**************************************************************************
-include ../config/Makefile
-CAMLRUN ?= ../boot/ocamlrun
-CAMLYACC ?= ../boot/ocamlyacc
-
-# Various commands and dir
-##########################
-ROOTDIR = ..
-OCAMLC = $(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib
-ifeq "$(wildcard $(ROOTDIR)/flexdll/Makefile)" ""
- FLEXLINK_ENV=
-else
- FLEXLINK_ENV=OCAML_FLEXLINK="$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/flexdll/flexlink.exe"
-endif
-OCAMLOPT = $(FLEXLINK_ENV) $(CAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib \
- -I $(ROOTDIR)/stdlib
-OCAMLDEP = $(CAMLRUN) $(ROOTDIR)/tools/ocamldep
-OCAMLLEX = $(CAMLRUN) $(ROOTDIR)/boot/ocamllex
-OCAMLLIB = $(LIBDIR)
-OCAMLBIN = $(BINDIR)
-
-OCAMLPP=-pp "grep -v DEBUG"
-
-# For installation
-##############
-MKDIR=mkdir
-CP=cp
-OCAMLDOC=ocamldoc
-OCAMLDOC_RUN=$(CAMLRUN) $(OCAMLDOC)
-OCAMLDOC_OPT=$(OCAMLDOC).opt
-OCAMLDOC_LIBCMA=odoc_info.cma
-OCAMLDOC_LIBCMI=odoc_info.cmi
-OCAMLDOC_LIBCMXA=odoc_info.cmxa
-OCAMLDOC_LIBA=odoc_info.$(A)
-INSTALL_LIBDIR=$(DESTDIR)$(OCAMLLIB)/ocamldoc
-INSTALL_CUSTOMDIR=$(INSTALL_LIBDIR)/custom
-INSTALL_BINDIR=$(DESTDIR)$(OCAMLBIN)
-
-INSTALL_MLIS=odoc_info.mli
-INSTALL_CMIS=$(INSTALL_MLIS:.mli=.cmi)
-
-# Compilation
-#############
-OCAMLSRCDIR=..
-INCLUDES_DEP=-I $(OCAMLSRCDIR)/parsing \
- -I $(OCAMLSRCDIR)/utils \
- -I $(OCAMLSRCDIR)/typing \
- -I $(OCAMLSRCDIR)/driver \
- -I $(OCAMLSRCDIR)/bytecomp \
- -I $(OCAMLSRCDIR)/toplevel/
-
-INCLUDES_NODEP= -I $(OCAMLSRCDIR)/stdlib \
- -I $(OCAMLSRCDIR)/otherlibs/str \
- -I $(OCAMLSRCDIR)/otherlibs/dynlink \
- -I $(OCAMLSRCDIR)/otherlibs/$(UNIXLIB) \
- -I $(OCAMLSRCDIR)/otherlibs/num \
- -I $(OCAMLSRCDIR)/otherlibs/$(GRAPHLIB)
-
-INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP)
-
-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 \
- odoc_messages.cmo\
- odoc_global.cmo\
- odoc_types.cmo\
- odoc_misc.cmo\
- odoc_text_parser.cmo\
- odoc_text_lexer.cmo\
- odoc_text.cmo\
- odoc_name.cmo\
- odoc_parameter.cmo\
- odoc_value.cmo\
- odoc_type.cmo\
- odoc_extension.cmo\
- odoc_exception.cmo\
- odoc_class.cmo\
- odoc_module.cmo\
- odoc_print.cmo \
- odoc_str.cmo\
- odoc_comments_global.cmo\
- odoc_parser.cmo\
- odoc_lexer.cmo\
- odoc_see_lexer.cmo\
- odoc_env.cmo\
- odoc_merge.cmo\
- odoc_sig.cmo\
- odoc_ast.cmo\
- odoc_control.cmo\
- odoc_inherit.cmo\
- odoc_search.cmo\
- odoc_scan.cmo\
- odoc_cross.cmo\
- odoc_comments.cmo\
- odoc_dep.cmo\
- odoc_analyse.cmo\
- odoc_info.cmo
-
-
-CMXFILES= $(CMOFILES:.cmo=.cmx)
-CMIFILES= $(CMOFILES:.cmo=.cmi)
-
-EXECMOFILES=$(CMOFILES) \
- odoc_dag2html.cmo \
- odoc_to_text.cmo \
- odoc_ocamlhtml.cmo \
- odoc_html.cmo \
- odoc_man.cmo \
- odoc_latex_style.cmo \
- odoc_latex.cmo \
- odoc_texi.cmo \
- odoc_dot.cmo \
- odoc_gen.cmo \
- odoc_args.cmo \
- odoc.cmo
-
-EXECMXFILES= $(EXECMOFILES:.cmo=.cmx)
-EXECMIFILES= $(EXECMOFILES:.cmo=.cmi)
-
-LIBCMOFILES=$(CMOFILES)
-LIBCMXFILES= $(LIBCMOFILES:.cmo=.cmx)
-LIBCMIFILES= $(LIBCMOFILES:.cmo=.cmi)
-
-all:
- $(MAKEREC) exe
- $(MAKEREC) lib
-
-exe: $(OCAMLDOC)
-lib: $(OCAMLDOC_LIBCMA) $(OCAMLDOC_LIBCMI)
-
-opt.opt: exeopt libopt
-exeopt: $(OCAMLDOC_OPT)
-libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI)
-
-debug:
- $(MAKEREC) OCAMLPP=""
-
-$(OCAMLDOC): $(EXECMOFILES)
- $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma \
- $(OCAMLSRCDIR)/compilerlibs/ocamlcommon.cma \
- $(LINKFLAGS) $(EXECMOFILES)
-$(OCAMLDOC_OPT): $(EXECMXFILES)
- $(OCAMLOPT) -o $@ -linkall unix.cmxa str.cmxa dynlink.cmxa \
- $(OCAMLSRCDIR)/compilerlibs/ocamlcommon.cmxa \
- $(LINKFLAGS) $(EXECMXFILES)
-
-$(OCAMLDOC_LIBCMA): $(LIBCMOFILES)
- $(OCAMLC) -a -o $@ $(LINKFLAGS) \
- $(LIBCMOFILES)
-$(OCAMLDOC_LIBCMXA): $(LIBCMXFILES)
- $(OCAMLOPT) -a -o $@ $(LINKFLAGS) \
- $(LIBCMXFILES)
-
-# Parsers and lexers dependencies :
-###################################
-odoc_text_parser.ml: odoc_text_parser.mly
-odoc_text_parser.mli: odoc_text_parser.mly
-
-odoc_parser.ml: odoc_parser.mly
-odoc_parser.mli:odoc_parser.mly
-
-odoc_text_lexer.ml: odoc_text_lexer.mll
-
-odoc_lexer.ml:odoc_lexer.mll
-
-odoc_ocamlhtml.ml: odoc_ocamlhtml.mll
-
-odoc_see_lexer.ml: odoc_see_lexer.mll
-
-
-# generic rules :
-#################
-
-.SUFFIXES: .mll .mly .ml .mli .cmo .cmi .cmx .cmxs
-
-.ml.cmo:
- $(OCAMLC) $(OCAMLPP) $(COMPFLAGS) -c $<
-
-.mli.cmi:
- $(OCAMLC) $(OCAMLPP) $(COMPFLAGS) -c $<
-
-.ml.cmx:
- $(OCAMLOPT) $(OCAMLPP) $(COMPFLAGS) -c $<
-
-.ml.cmxs:
- $(OCAMLOPT) -shared -o $@ $(OCAMLPP) $(COMPFLAGS) $<
-
-.mll.ml:
- $(OCAMLLEX) $<
-
-.mly.ml:
- $(CAMLYACC) -v $<
-
-.mly.mli:
- $(CAMLYACC) -v $<
-
-# Installation targets
-######################
-install: dummy
- $(MKDIR) -p "$(INSTALL_BINDIR)"
- $(MKDIR) -p "$(INSTALL_LIBDIR)"
- $(CP) $(OCAMLDOC) "$(INSTALL_BINDIR)/$(OCAMLDOC)$(EXE)"
- $(CP) ocamldoc.hva *.cmi $(OCAMLDOC_LIBCMA) "$(INSTALL_LIBDIR)"
- $(CP) $(INSTALL_MLIS) $(INSTALL_CMIS) "$(INSTALL_LIBDIR)"
-
-installopt:
- if test -f $(OCAMLDOC_OPT); then $(MAKEREC) installopt_really; fi
-
-installopt_really:
- $(MKDIR) -p "$(INSTALL_BINDIR)"
- $(MKDIR) -p "$(INSTALL_LIBDIR)"
- $(CP) $(OCAMLDOC_OPT) "$(INSTALL_BINDIR)/$(OCAMLDOC_OPT)$(EXE)"
- $(CP) ocamldoc.hva $(OCAMLDOC_LIBA) $(OCAMLDOC_LIBCMXA) \
- "$(INSTALL_LIBDIR)"
- $(CP) $(INSTALL_MLIS) $(INSTALL_CMIS) "$(INSTALL_LIBDIR)"
-
-
-# backup, clean and depend :
-############################
-
-clean:: dummy
- @rm -f *~ \#*\#
- @rm -f $(OCAMLDOC) $(OCAMLDOC_OPT) *.cma *.cmxa *.cmo *.cmi *.cmx *.$(A) *.$(O)
- @rm -f odoc_parser.output odoc_text_parser.output
- @rm -f odoc_lexer.ml odoc_text_lexer.ml odoc_see_lexer.ml odoc_ocamlhtml.ml
- @rm -f odoc_parser.ml odoc_parser.mli odoc_text_parser.ml odoc_text_parser.mli
- @rm -rf stdlib_man
- @rm -f generators/*.cm[aiox] generators/*.$(A) generators/*.$(O) generators/*.cmx[as]
-
-depend::
- $(CAMLYACC) odoc_text_parser.mly
- $(CAMLYACC) odoc_parser.mly
- $(OCAMLLEX) odoc_text_lexer.mll
- $(OCAMLLEX) odoc_lexer.mll
- $(OCAMLLEX) odoc_ocamlhtml.mll
- $(OCAMLLEX) odoc_see_lexer.mll
- $(OCAMLDEP) -slash $(INCLUDES_DEP) *.mll *.mly *.ml *.mli > .depend
-
-dummy:
-
-include .depend
+include Makefile
let open_mod env m =
let open Asttypes in
let lid = {loc = Location.in_file "ocamldoc command line";
- txt = Longident.Lident m } in
+ txt = Longident.parse 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 *)
with Odoc_text.Text_syntax (l, c, s) ->
raise (Failure (Odoc_messages.text_parse_error l c s))
in
+ let m_info =
+ Some Odoc_types.{dummy_info with i_desc= Some txt } in
let m =
{
Odoc_module.m_name = mod_name ;
Odoc_module.m_type = Types.Mty_signature [] ;
- Odoc_module.m_info = None ;
+ Odoc_module.m_info;
Odoc_module.m_is_interface = true ;
Odoc_module.m_file = file ;
- Odoc_module.m_kind = Odoc_module.Module_struct
- [Odoc_module.Element_module_comment txt] ;
+ Odoc_module.m_kind = Odoc_module.Module_struct [] ;
Odoc_module.m_loc =
{ Odoc_types.loc_impl = None ;
Odoc_types.loc_inter = Some (Location.in_file file) } ;
Odoc_global.files := !Odoc_global.files @ [Odoc_global.Text_file s]),
M.option_text ;
"-warn-error", Arg.Set Odoc_global.warn_error, M.werr ;
+ "-show-missed-crossref", Arg.Set Odoc_global.show_missed_crossref,
+ M.show_missed_crossref;
"-hide-warnings", Arg.Clear Odoc_config.print_warnings, M.hide_warnings ;
"-o", Arg.String (fun s -> Odoc_global.out_file := s), M.out_file ;
"-d", Arg.String (fun s -> Odoc_global.target_dir := s), M.target_dir ;
in
(* continue if the body is still a function *)
match next_exp.exp_desc with
- Texp_function (_, pat_exp_list, _) ->
+ Texp_function { cases = pat_exp_list ; _ } ->
p :: (tt_analyse_function_parameters env current_comment_opt pat_exp_list)
| _ ->
(* something else ; no more parameter *)
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 { cases = pat_exp_list2; _ }) ->
(* a new function is defined *)
let name_pre = Name.from_ident ident in
let name = Name.parens_if_infix name_pre in
*)
let rec tt_analyse_method_expression env current_method_name comment_opt ?(first=true) exp =
match exp.Typedtree.exp_desc with
- Typedtree.Texp_function (_, pat_exp_list, _) ->
+ Typedtree.Texp_function { cases = pat_exp_list; _ } ->
(
match pat_exp_list with
[] ->
let analyse_typed_tree source_file input_file
(parsetree : Parsetree.structure) (typedtree : typedtree) =
let (tree_structure, _) = typedtree in
- let complete_source_file =
- try
- let curdir = Sys.getcwd () in
- let (dirname, basename) = (Filename.dirname source_file, Filename.basename source_file) in
- Sys.chdir dirname ;
- let complete = Filename.concat (Sys.getcwd ()) basename in
- Sys.chdir curdir ;
- complete
- with
- Sys_error s ->
- prerr_endline s ;
- incr Odoc_global.errors ;
- source_file
- in
- prepare_file complete_source_file input_file;
+ prepare_file source_file input_file;
(* We create the t_module for this file. *)
let mod_name = String.capitalize_ascii (Filename.basename (Filename.chop_extension source_file)) in
let (len,info_opt) = My_ir.first_special !file_name !file in
| RK_const -> Odoc_messages.cross_const_not_found
) name
+let query module_list name =
+ match get_known_elements name with
+ | [] ->
+ (
+ try
+ let re = Str.regexp ("^"^(Str.quote name)^"$") in
+ let t = Odoc_search.find_section module_list re in
+ let v2 = (name, Some (RK_section t)) in
+ add_verified v2 ;
+ (name, Some (RK_section t))
+ with
+ Not_found ->
+ (name, None)
+ )
+ | ele :: _ ->
+ (* we look for the first element with this name *)
+ let (name, kind) =
+ match ele with
+ Odoc_search.Res_module m -> (m.m_name, RK_module)
+ | Odoc_search.Res_module_type mt -> (mt.mt_name, RK_module_type)
+ | Odoc_search.Res_class c -> (c.cl_name, RK_class)
+ | Odoc_search.Res_class_type ct -> (ct.clt_name, RK_class_type)
+ | Odoc_search.Res_value v -> (v.val_name, RK_value)
+ | Odoc_search.Res_type t -> (t.ty_name, RK_type)
+ | Odoc_search.Res_extension x -> (x.xt_name, RK_extension)
+ | 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 _-> 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) ->
+ (Printf.sprintf "%s.%s" t.ty_name f.vc_name, RK_const)
+ in
+ add_verified (name, Some kind) ;
+ (name, Some kind)
+
+
+let rec search_within_ancestry
+ (finalize,initial_name,query as param) ?parent_name name =
+ let name = Odoc_name.normalize_name name in
+ let res = query name in
+ match res with
+ | (name, Some k) -> finalize (Some (name,k))
+ | (_, None) ->
+ match parent_name with
+ | None ->
+ finalize None
+ (* *)
+ | Some p ->
+ let parent_name =
+ match Name.father p with
+ "" -> None
+ | s -> Some s
+ in
+ search_within_ancestry param
+ ?parent_name (Name.concat p initial_name)
+
+let search_within_ancestry finalize query ?parent_name name =
+ search_within_ancestry (finalize, name, query) ?parent_name name
+
+
let rec assoc_comments_text_elements parent_name module_list t_ele =
match t_ele with
| Raw _
- | Code _
| CodePre _
| Latex _
| Verbatim _ -> t_ele
| Title (n, l_opt, t) -> Title (n, l_opt, (assoc_comments_text parent_name module_list t))
| Link (s, t) -> Link (s, (assoc_comments_text parent_name module_list t))
| Ref (initial_name, None, text_option) ->
- (
- let rec iter_parent ?parent_name name =
- let name = Odoc_name.normalize_name name in
- let res =
- match get_known_elements name with
- [] ->
- (
- try
- let re = Str.regexp ("^"^(Str.quote name)^"$") in
- let t = Odoc_search.find_section module_list re in
- let v2 = (name, Some (RK_section t)) in
- add_verified v2 ;
- (name, Some (RK_section t))
- with
- Not_found ->
- (name, None)
- )
- | ele :: _ ->
- (* we look for the first element with this name *)
- let (name, kind) =
- match ele with
- Odoc_search.Res_module m -> (m.m_name, RK_module)
- | Odoc_search.Res_module_type mt -> (mt.mt_name, RK_module_type)
- | Odoc_search.Res_class c -> (c.cl_name, RK_class)
- | Odoc_search.Res_class_type ct -> (ct.clt_name, RK_class_type)
- | Odoc_search.Res_value v -> (v.val_name, RK_value)
- | Odoc_search.Res_type t -> (t.ty_name, RK_type)
- | Odoc_search.Res_extension x -> (x.xt_name, RK_extension)
- | 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 _-> 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) ->
- (Printf.sprintf "%s.%s" t.ty_name f.vc_name, RK_const)
- in
- add_verified (name, Some kind) ;
- (name, Some kind)
- in
- match res with
- | (name, Some k) -> Ref (name, Some k, text_option)
- | (_, None) ->
- match parent_name with
- None ->
- Odoc_global.pwarning (Odoc_messages.cross_element_not_found initial_name);
- Ref (initial_name, None, text_option)
- | Some p ->
- let parent_name =
- match Name.father p with
- "" -> None
- | s -> Some s
- in
- iter_parent ?parent_name (Name.concat p initial_name)
- in
- iter_parent ~parent_name initial_name
- )
+ let finalize = function
+ | Some (name,k) -> Ref (name, Some k, text_option)
+ | None ->
+ Odoc_global.pwarning
+ (Odoc_messages.cross_element_not_found initial_name);
+ Ref (initial_name, None, text_option) in
+ search_within_ancestry finalize (query module_list) ~parent_name initial_name
+ | Code s ->
+ if not !Odoc_global.show_missed_crossref then
+ t_ele
+ else (* Check if s could be turned into a valid cross-reference *)
+ let name = String.trim s in
+ begin
+ (* First, we ignore code fragments with more than one space-separated
+ words: "word1 word2" *)
+ try (ignore (String.index name ' '); t_ele)
+ with Not_found ->
+ if name = "" then t_ele
+ else
+ let first_char = name.[0] in
+ (* Then, we only consider code fragments which start with a
+ distinctly uppercase letter *)
+ if Char.uppercase_ascii first_char <> first_char ||
+ Char.lowercase_ascii first_char = first_char then
+ t_ele
+ else
+ (* Some path analysis auxiliary functions *)
+ let path s =
+ String.split_on_char '.' s
+ in
+ let filter =
+ List.filter
+ (fun s -> s <> "" && s.[0] = Char.uppercase_ascii s.[0]) in
+ let rec is_prefix prefix full =
+ match prefix, full with
+ | [], _ -> true
+ | a :: pre, b :: f when a = b -> is_prefix pre f
+ | _ -> false in
+ let p = filter @@ path name and parent_p = path parent_name in
+ let is_path_suffix () =
+ is_prefix (List.rev @@ p) (List.rev @@ parent_p ) in
+ (* heuristic:
+ - if name = parent_name: we are using the name of an element
+ or module in its definition, no need of cross_reference
+ - if the path of name is a suffix of the parent path, we
+ are in the same module, maybe the same function. To decreace
+ the false positive rate, we stop here *)
+ if name = parent_name || is_path_suffix () then
+ t_ele
+ else
+ let finalize = function
+ | None -> t_ele
+ | Some _ ->
+ Odoc_global.pwarning @@
+ Odoc_messages.code_could_be_cross_reference name parent_name;
+ t_ele in
+ search_within_ancestry finalize (query module_list) ~parent_name
+ name
+ end
| Ref (initial_name, Some kind, text_option) ->
(
let rec iter_parent ?parent_name name =
let errors = ref 0
let warn_error = ref false
+let show_missed_crossref = ref false
let pwarning s =
if !Odoc_config.print_warnings then prerr_endline (Odoc_messages.warning^": "^s);
(** Indicate if a warning is an error. *)
val warn_error : bool ref
+(** Show code fragments that could be transformed into a cross-reference. *)
+val show_missed_crossref: bool ref
+
(** Print the given warning, adding it to the list of {!errors}
if {!warn_error} is [true]. *)
val pwarning : string -> unit
method html_of_Link b s t =
bs b "<a href=\"";
- bs b s ;
+ bs b (self#escape s);
bs b "\">";
self#html_of_text b t;
bs b "</a>"
".indextable {border: 1px #ddd solid; border-collapse: collapse}";
".indextable td, .indextable th {border: 1px #ddd solid; min-width: 80px}";
".indextable td.module {background-color: #eee ; padding-left: 2px; padding-right: 2px}";
- ".indextable td.module a {color: 4E6272; text-decoration: none; display: block; width: 100%}";
+ ".indextable td.module a {color: #4E6272; text-decoration: none; display: block; width: 100%}";
".indextable td.module a:hover {text-decoration: underline; background-color: transparent}";
".deprecated {color: #888; font-style: italic}" ;
(
match modu with
None ->
+ (* first we close the current <pre> tag, since the following
+ list of module elements is not preformatted *)
+ bs b "</pre>";
bs b "<div class=\"sig_block\">";
List.iter (self#html_of_module_element b father) eles;
- bs b "</div>"
+ bs b "</div>";
+ bs b "\n<pre>"
| Some m ->
let (html_file, _) = Naming.html_files m.m_name in
bp b " <a href=\"%s\">..</a> " html_file
(
match modu with
None ->
+ (*close the current <pre> tag, to avoid anarchic line breaks
+ in the list of module elements *)
+ bs b "</pre>";
bs b "<div class=\"sig_block\">";
List.iter (self#html_of_module_element b father) eles;
- bs b "</div>"
+ bs b "</div>";
+ bs b "<pre>";
| Some m ->
let (html_file, _) = Naming.html_files m.m_name in
bp b " <a href=\"%s\">..</a> " html_file
);
bs b "</h1>\n";
- if not modu.m_text_only then self#html_of_module b ~with_link: false modu;
+ if not modu.m_text_only then
+ self#html_of_module b ~with_link: false modu
+ else
+ self#html_of_info ~indent:false b modu.m_info;
(* parameters for functors *)
self#html_of_module_parameter_list b
method latex_of_cstr_args ( (fmt,flush) as f) mod_name (args, ret) =
match args, ret with
- | Cstr_tuple [], None -> []
+ | Cstr_tuple [], None -> [CodePre(flush())]
| 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);
+ | Cstr_tuple t as l, Some r ->
+ let res = self#normal_type mod_name r in
+ if t = [] then
+ p fmt " :@ %s" res
+ else
+ p fmt " :@ %s -> %s" (self#normal_cstr_args ~par:false mod_name l) res
+ ;
[CodePre (flush())]
| Cstr_record l, None ->
p fmt " of@ ";
p fmt2 "@[<h 6> | %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 -> ()
+ 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
+ );
+ [CodePre (flush2 ())]
+ in
Latex (self#make_label (self#extension_label x.xt_name)) :: l @ c
@ (match x.xt_text with
None -> []
p fmt2 "@[<hov 2>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
+ 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
method generate_for_top_module fmt m =
let (first_t, rest_t) = self#first_and_rest_of_info m.m_info in
let text =
- if m.m_text_only then
- [ Title (1, None, [Raw m.m_name] @
- (match first_t with
- [] -> []
- | t -> (Raw " : ") :: t)
- ) ;
- ]
- else
- [ Title (1, None,
- [ Raw (Odoc_messages.modul^" ") ; Code m.m_name ] @
- (match first_t with
- [] -> []
- | t -> (Raw " : ") :: t)) ;
- ]
+ let title =
+ if m.m_text_only then [Raw m.m_name]
+ else [ Raw (Odoc_messages.modul^" ") ; Code m.m_name ] in
+ let subtitle = match first_t with
+ | [] -> []
+ | t -> (Raw " : ") :: t in
+ [ Title (1, None, title @ subtitle ) ]
in
self#latex_of_text fmt text;
self#latex_for_module_label fmt m;
"\t\tgenerators"
let load_file = "<file.cm[o|a|xs]> Load file defining a new documentation generator"
let werr = " Treat ocamldoc warnings as errors"
+let show_missed_crossref = " Show missed cross-reference opportunities"
let hide_warnings = " do not print ocamldoc warnings"
let target_dir = "<dir> Generate files in directory <dir>, rather than in current\n"^
"\t\tdirectory (for man and HTML generators)"
let parse_error = "Parse error"
let text_parse_error l c s =
let lines = Str.split (Str.regexp_string "\n") s in
- (List.nth lines l) ^ "\n" ^ (String.make c ' ') ^ "^"
+ "Error parsing text:\n"
+ ^ (List.nth lines l) ^ "\n"
+ ^ (String.make c ' ') ^ "^"
let file_not_found_in_paths paths name =
Printf.sprintf "No file %s found in the load paths: \n%s"
let cross_recfield_not_found n = Printf.sprintf "Record field %s not found" n
let cross_const_not_found n = Printf.sprintf "Constructor %s not found" n
+let code_could_be_cross_reference n parent =
+ Printf.sprintf "Code element [%s] in %s corresponds to a known \
+ cross-referenceable element, it might be worthwhile to replace it \
+ with {!%s}" n parent n
+
+
let object_end = "object ... end"
let struct_end = "struct ... end"
let sig_end = "sig ... end"
[]
l
-(** Returns the list of elements of a module.
- @param trans indicates if, for aliased modules, we must perform a transitive search.*)
-let rec module_elements ?(trans=true) m =
- let rec iter_kind = function
- Module_struct l ->
- print_DEBUG "Odoc_module.module_element: Module_struct";
- l
- | Module_alias ma ->
- print_DEBUG "Odoc_module.module_element: Module_alias";
- if trans then
- match ma.ma_module with
- None -> []
- | Some (Mod m) -> module_elements m
- | Some (Modtype mt) -> module_type_elements mt
- else
- []
- | Module_functor (_, k)
- | Module_apply (k, _) ->
- print_DEBUG "Odoc_module.module_element: Module_functor ou Module_apply";
- iter_kind k
- | Module_with (tk,_) ->
- print_DEBUG "Odoc_module.module_element: Module_with";
- module_type_elements ~trans: trans
- { mt_name = "" ; mt_info = None ; mt_type = None ;
- mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ;
- mt_loc = Odoc_types.dummy_loc ;
- }
- | Module_constraint (k, _tk) ->
- print_DEBUG "Odoc_module.module_element: Module_constraint";
- (* FIXME : use k or tk ? *)
- module_elements ~trans: trans
- { m_name = "" ;
- m_info = None ;
- m_type = Types.Mty_signature [] ;
- m_is_interface = false ; m_file = "" ; m_kind = k ;
- m_loc = Odoc_types.dummy_loc ;
- m_top_deps = [] ;
- m_code = None ;
- m_code_intf = None ;
- m_text_only = false ;
- }
- | Module_typeof _ -> []
- | Module_unpack _ -> []
-(*
- module_type_elements ~trans: trans
- { mt_name = "" ; mt_info = None ; mt_type = None ;
- mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ;
- mt_loc = Odoc_types.dummy_loc }
-*)
- in
- iter_kind m.m_kind
+module S = Misc.StringSet
+
(** Returns the list of elements of a module type.
@param trans indicates if, for aliased modules, we must perform a transitive search.*)
-and module_type_elements ?(trans=true) mt =
+let rec module_type_elements ?(trans=true) mt =
let rec iter_kind = function
| None -> []
| Some (Module_type_struct l) -> l
in
iter_kind mt.mt_kind
+(** Returns the list of elements of a module.
+ @param trans indicates if, for aliased modules, we must perform a transitive search.
+*)
+let module_elements ?(trans=true) m =
+(* visited is used to guard against aliases loop
+ (e.g [module rec M:sig end=M] induced loop.
+*)
+ let rec module_elements visited ?(trans=true) m =
+ let rec iter_kind = function
+ Module_struct l ->
+ print_DEBUG "Odoc_module.module_elements: Module_struct";
+ l
+ | Module_alias ma ->
+ print_DEBUG "Odoc_module.module_elements: Module_alias";
+ if trans then
+ match ma.ma_module with
+ None -> []
+ | Some (Mod m') ->
+ if S.mem m'.m_name visited then
+ []
+ else
+ module_elements (S.add m'.m_name visited) m'
+ | Some (Modtype mt) -> module_type_elements mt
+ else
+ []
+ | Module_functor (_, k)
+ | Module_apply (k, _) ->
+ print_DEBUG "Odoc_module.module_elements: Module_functor ou Module_apply";
+ iter_kind k
+ | Module_with (tk,_) ->
+ print_DEBUG "Odoc_module.module_elements: Module_with";
+ module_type_elements ~trans: trans
+ { mt_name = "" ; mt_info = None ; mt_type = None ;
+ mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ;
+ mt_loc = Odoc_types.dummy_loc ;
+ }
+ | Module_constraint (k, _tk) ->
+ print_DEBUG "Odoc_module.module_elements: Module_constraint";
+ (* FIXME : use k or tk ? *)
+ module_elements visited ~trans: trans
+ { m_name = "" ;
+ m_info = None ;
+ m_type = Types.Mty_signature [] ;
+ m_is_interface = false ; m_file = "" ; m_kind = k ;
+ m_loc = Odoc_types.dummy_loc ;
+ m_top_deps = [] ;
+ m_code = None ;
+ m_code_intf = None ;
+ m_text_only = false ;
+ }
+ | Module_typeof _ -> []
+ | Module_unpack _ -> []
+(*
+ module_type_elements ~trans: trans
+ { mt_name = "" ; mt_info = None ; mt_type = None ;
+ mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ;
+ mt_loc = Odoc_types.dummy_loc }
+*)
+ in
+ iter_kind m.m_kind in
+ module_elements S.empty ~trans m
+
(** Returns the list of values of a module.
@param trans indicates if, for aliased modules, we must perform a transitive search.*)
let module_values ?(trans=true) m = values (module_elements ~trans m)
(** The module is a functor if is defined as a functor or if it is an alias for a functor. *)
let module_is_functor m =
- let rec iter = function
+ let rec iter visited = function
Module_functor _ -> true
| Module_alias ma ->
(
- match ma.ma_module with
- None -> false
- | Some (Mod mo) -> iter mo.m_kind
- | Some (Modtype mt) -> module_type_is_functor mt
+ not (S.mem ma.ma_name visited)
+ &&
+ match ma.ma_module with
+ None -> false
+ | Some (Mod mo) -> iter (S.add ma.ma_name visited) mo.m_kind
+ | Some (Modtype mt) -> module_type_is_functor mt
)
| Module_constraint (k, _) ->
- iter k
+ iter visited k
| _ -> false
in
- iter m.m_kind
+ iter S.empty m.m_kind
(** Returns the list of values of a module type.
@param trans indicates if, for aliased modules, we must perform a transitive search.*)
| Ptyp_object (fields, _) ->
let rec f = function
| [] -> []
- | ("",_,_) :: _ ->
+ | ({txt=""},_,_) :: _ ->
(* Fields with no name have been eliminated previously. *)
assert false
- | (name, _atts, ct) :: [] ->
+ | ({txt=name}, _atts, ct) :: [] ->
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 ->
+ | ({txt=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
in
let is_named_field field =
match field with
- | ("",_,_) -> false
+ | ({txt=""},_,_) -> false
| _ -> true
in
(0, f @@ List.filter is_named_field fields)
let loc = item.Parsetree.pctf_loc in
match item.Parsetree.pctf_desc with
- | Parsetree.Pctf_val (name, mutable_flag, virtual_flag, _) ->
+ | Parsetree.Pctf_val ({txt=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.start loc) in
let (inher_l, eles) = f (pos_end + maybe_more) q in
(inher_l, eles_comments @ ((Class_attribute att) :: eles))
- | Parsetree.Pctf_method (name, private_flag, virtual_flag, _) ->
+ | Parsetree.Pctf_method ({txt=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.start loc) in
let analyse_signature source_file input_file
(ast : Parsetree.signature) (signat : Types.signature) =
- let complete_source_file =
- try
- let curdir = Sys.getcwd () in
- let (dirname, basename) = (Filename.dirname source_file, Filename.basename source_file) in
- Sys.chdir dirname ;
- let complete = Filename.concat (Sys.getcwd ()) basename in
- Sys.chdir curdir ;
- complete
- with
- Sys_error s ->
- prerr_endline s ;
- incr Odoc_global.errors ;
- source_file
- in
- prepare_file complete_source_file input_file;
+ prepare_file source_file input_file;
(* We create the t_module for this file. *)
let mod_name = String.capitalize_ascii
(Filename.basename (try Filename.chop_extension source_file with _ -> source_file))
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)/"
+ cp $(LIBNAME).cma $(CMIFILES) $(CMIFILES:.cmi=.mli) \
+ $(CMIFILES:.cmi=.cmti) "$(INSTALL_LIBDIR)/"
if test -n "$(HEADERS)"; then \
cp $(HEADERS) "$(INSTALL_LIBDIR)/caml/"; fi
bigarray_stubs.o: bigarray_stubs.c ../../byterun/caml/alloc.h \
- ../../byterun/caml/misc.h ../../byterun/caml/config.h \
- ../../byterun/caml/../../config/m.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 \
bigarray.h ../../byterun/caml/custom.h ../../byterun/caml/fail.h \
../../byterun/caml/intext.h ../../byterun/caml/io.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
-mmap_unix.o: mmap_unix.c bigarray.h ../../byterun/caml/config.h \
- ../../byterun/caml/../../config/m.h \
+mmap_unix.o: mmap_unix.c bigarray.h ../../byterun/caml/compatibility.h \
+ ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
../../byterun/caml/misc.h ../../byterun/caml/custom.h \
../../byterun/caml/fail.h ../../byterun/caml/io.h \
../../byterun/caml/sys.h ../../byterun/caml/signals.h
-mmap_win32.o: mmap_win32.c bigarray.h ../../byterun/caml/config.h \
- ../../byterun/caml/../../config/m.h \
+mmap_win32.o: mmap_win32.c bigarray.h ../../byterun/caml/compatibility.h \
+ ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
../../byterun/caml/misc.h ../../byterun/caml/alloc.h \
../../byterun/caml/custom.h ../../byterun/caml/fail.h \
#* *
#**************************************************************************
-include Makefile.shared
+LIBNAME=bigarray
+EXTRACFLAGS=-I../$(UNIXLIB) -DIN_OCAML_BIGARRAY
+EXTRACAMLFLAGS=-I ../$(UNIXLIB)
+COBJS=bigarray_stubs.$(O) mmap_$(UNIX_OR_WIN32).$(O)
+CAMLOBJS=bigarray.cmo
+HEADERS=bigarray.h
+
+include ../Makefile
depend:
$(CC) -MM $(CFLAGS) *.c > .depend
- $(CAMLRUN) ../../tools/ocamldep -slash *.mli *.ml >> .depend
+ $(CAMLRUN) $(ROOTDIR)/tools/ocamldep -slash *.mli *.ml >> .depend
+
+ifeq "$(TOOLCHAIN)" "msvc"
+.depend.nt: .depend
+ sed -e 's/\.o/.$(O)/g' $< > $@
+
+include .depend.nt
+else
include .depend
+endif
#* *
#**************************************************************************
-# It would be better to move that to config/Makefile.*
-UNIX_OR_WIN32=win32
-
include Makefile
-
-.depend.nt: .depend
- sed -e 's/\.o/.$(O)/g' .depend > .depend.nt
-
-include .depend.nt
+++ /dev/null
-#**************************************************************************
-#* *
-#* 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
map_internal fd kind layout shared dims pos
end
+module Array0 = struct
+ type ('a, 'b, 'c) t = ('a, 'b, 'c) Genarray.t
+ let create kind layout =
+ Genarray.create kind layout [||]
+ let get arr = Genarray.get arr [||]
+ let set arr = Genarray.set arr [||]
+ external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
+ external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
+
+ let size_in_bytes arr = kind_size_in_bytes (kind arr)
+
+ external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit"
+ external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
+
+ let of_value kind layout v =
+ let a = create kind layout in
+ set a v;
+ a
+end
+
module Array1 = struct
type ('a, 'b, 'c) t = ('a, 'b, 'c) Genarray.t
let create kind layout dim =
(kind_size_in_bytes (kind arr)) * (dim arr)
external sub: ('a, 'b, 'c) t -> int -> int -> ('a, 'b, 'c) t = "caml_ba_sub"
+ let slice (type t) (a : (_, _, t) Genarray.t) n =
+ match layout a with
+ | C_layout -> (Genarray.slice_left a [|n|] : (_, _, t) Genarray.t)
+ | Fortran_layout -> (Genarray.slice_right a [|n|]: (_, _, t) Genarray.t)
external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit"
external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
let of_array (type t) kind (layout: t layout) data =
Genarray.map_file fd ?pos kind layout shared [|dim1;dim2;dim3|]
end
+external genarray_of_array0: ('a, 'b, 'c) Array0.t -> ('a, 'b, 'c) Genarray.t
+ = "%identity"
external genarray_of_array1: ('a, 'b, 'c) Array1.t -> ('a, 'b, 'c) Genarray.t
= "%identity"
external genarray_of_array2: ('a, 'b, 'c) Array2.t -> ('a, 'b, 'c) Genarray.t
= "%identity"
external genarray_of_array3: ('a, 'b, 'c) Array3.t -> ('a, 'b, 'c) Genarray.t
= "%identity"
+let array0_of_genarray a =
+ if Genarray.num_dims a = 0 then a
+ else invalid_arg "Bigarray.array0_of_genarray"
let array1_of_genarray a =
if Genarray.num_dims a = 1 then a
else invalid_arg "Bigarray.array1_of_genarray"
external reshape:
('a, 'b, 'c) Genarray.t -> int array -> ('a, 'b, 'c) Genarray.t
= "caml_ba_reshape"
+let reshape_0 a = reshape a [||]
let reshape_1 a dim1 = reshape a [|dim1|]
let reshape_2 a dim1 dim2 = reshape a [|dim1;dim2|]
let reshape_3 a dim1 dim2 dim3 = reshape a [|dim1;dim2;dim3|]
({!Bigarray.int16_signed_elt} or {!Bigarray.int16_unsigned_elt}),
- OCaml integers (signed, 31 bits on 32-bit architectures,
63 bits on 64-bit architectures) ({!Bigarray.int_elt}),
-- 32-bit signed integer ({!Bigarray.int32_elt}),
+- 32-bit signed integers ({!Bigarray.int32_elt}),
- 64-bit signed integers ({!Bigarray.int64_elt}),
- platform-native signed integers (32 bits on 32-bit architectures,
64 bits on 64-bit architectures) ({!Bigarray.nativeint_elt}).
sig
type ('a, 'b, 'c) t
(** The type [Genarray.t] is the type of big arrays with variable
- numbers of dimensions. Any number of dimensions between 1 and 16
+ numbers of dimensions. Any number of dimensions between 0 and 16
is supported.
The three type parameters to [Genarray.t] identify the array element
the initial values of array elements is unspecified.
[Genarray.create] raises [Invalid_argument] if the number of dimensions
- is not in the range 1 to 16 inclusive, or if one of the dimensions
+ is not in the range 0 to 16 inclusive, or if one of the dimensions
is negative. *)
external num_dims: ('a, 'b, 'c) t -> int = "caml_ba_num_dims"
end
+(** {6 Zero-dimensional arrays} *)
+
+(** Zero-dimensional arrays. The [Array0] structure provides operations
+ similar to those of {!Bigarray.Genarray}, but specialized to the case
+ of zero-dimensional arrays that only contain a single scalar value.
+ Statically knowing the number of dimensions of the array allows
+ faster operations, and more precise static type-checking.
+ @since 4.05.0 *)
+module Array0 : sig
+ type ('a, 'b, 'c) t
+ (** The type of zero-dimensional big arrays whose elements have
+ OCaml type ['a], representation kind ['b], and memory layout ['c]. *)
+
+ val create: ('a, 'b) kind -> 'c layout -> ('a, 'b, 'c) t
+ (** [Array0.create kind layout] returns a new bigarray of zero dimension.
+ [kind] and [layout] determine the array element kind and the array
+ layout as described for {!Genarray.create}. *)
+
+ external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
+ (** Return the kind of the given big array. *)
+
+ external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
+ (** Return the layout of the given big array. *)
+
+ val size_in_bytes : ('a, 'b, 'c) t -> int
+ (** [size_in_bytes a] is [a]'s {!kind_size_in_bytes}. *)
+
+ val get: ('a, 'b, 'c) t -> 'a
+ (** [Array0.get a] returns the only element in [a]. *)
+
+ val set: ('a, 'b, 'c) t -> 'a -> unit
+ (** [Array0.set a x v] stores the value [v] in [a]. *)
+
+ external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit"
+ (** Copy the first big array to the second big array.
+ See {!Genarray.blit} for more details. *)
+
+ external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
+ (** Fill the given big array with the given value.
+ See {!Genarray.fill} for more details. *)
+
+ val of_value: ('a, 'b) kind -> 'c layout -> 'a -> ('a, 'b, 'c) t
+ (** Build a zero-dimensional big array initialized from the
+ given value. *)
+
+end
+
+
(** {6 One-dimensional arrays} *)
(** One-dimensional arrays. The [Array1] structure provides operations
similar to those of
{!Bigarray.Genarray}, but specialized to the case of one-dimensional arrays.
- (The [Array2] and [Array3] structures below provide operations
+ (The {!Array2} and {!Array3} structures below provide operations
specialized for two- and three-dimensional arrays.)
Statically knowing the number of dimensions of the array allows
faster operations, and more precise static type-checking. *)
(** [Array1.create kind layout dim] returns a new bigarray of
one dimension, whose size is [dim]. [kind] and [layout]
determine the array element kind and the array layout
- as described for [Genarray.create]. *)
+ as described for {!Genarray.create}. *)
external dim: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
(** Return the size (dimension) of the given one-dimensional
external sub: ('a, 'b, 'c) t -> int -> int -> ('a, 'b, 'c) t
= "caml_ba_sub"
(** Extract a sub-array of the given one-dimensional big array.
- See [Genarray.sub_left] for more details. *)
+ See {!Genarray.sub_left} for more details. *)
+
+ val slice: ('a, 'b, 'c) t -> int -> ('a, 'b, 'c) Array0.t
+ (** Extract a scalar (zero-dimensional slice) of the given one-dimensional
+ big array. The integer parameter is the index of the scalar to
+ extract. See {!Bigarray.Genarray.slice_left} and
+ {!Bigarray.Genarray.slice_right} for more details.
+ @since 4.05.0 *)
external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit
= "caml_ba_blit"
(** Copy the first big array to the second big array.
- See [Genarray.blit] for more details. *)
+ See {!Genarray.blit} for more details. *)
external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
(** Fill the given big array with the given value.
- See [Genarray.fill] for more details. *)
+ See {!Genarray.fill} for more details. *)
val of_array: ('a, 'b) kind -> 'c layout -> 'a array -> ('a, 'b, 'c) t
(** Build a one-dimensional big array initialized from the
(** {6 Coercions between generic big arrays and fixed-dimension big arrays} *)
+external genarray_of_array0 :
+ ('a, 'b, 'c) Array0.t -> ('a, 'b, 'c) Genarray.t = "%identity"
+(** Return the generic big array corresponding to the given zero-dimensional
+ big array. @since 4.05.0 *)
+
external genarray_of_array1 :
('a, 'b, 'c) Array1.t -> ('a, 'b, 'c) Genarray.t = "%identity"
(** Return the generic big array corresponding to the given one-dimensional
(** Return the generic big array corresponding to the given three-dimensional
big array. *)
+val array0_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array0.t
+(** Return the zero-dimensional big array corresponding to the given
+ generic big array. Raise [Invalid_argument] if the generic big array
+ does not have exactly zero dimension.
+ @since 4.05.0 *)
+
val array1_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array1.t
(** Return the one-dimensional big array corresponding to the given
generic big array. Raise [Invalid_argument] if the generic big array
of the dimensions of [b] must be equal to [i1 * ... * iN].
Otherwise, [Invalid_argument] is raised. *)
+val reshape_0 : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array0.t
+(** Specialized version of {!Bigarray.reshape} for reshaping to
+ zero-dimensional arrays.
+ @since 4.05.0 *)
+
val reshape_1 : ('a, 'b, 'c) Genarray.t -> int -> ('a, 'b, 'c) Array1.t
(** Specialized version of {!Bigarray.reshape} for reshaping to
one-dimensional arrays. *)
struct caml_ba_array * b;
intnat dimcopy[CAML_BA_MAX_NUM_DIMS];
- Assert(num_dims >= 1 && num_dims <= CAML_BA_MAX_NUM_DIMS);
+ Assert(num_dims >= 0 && num_dims <= CAML_BA_MAX_NUM_DIMS);
Assert((flags & CAML_BA_KIND_MASK) <= CAML_BA_CHAR);
for (i = 0; i < num_dims; i++) dimcopy[i] = dim[i];
size = 0;
int i, flags;
num_dims = Wosize_val(vdim);
- if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS)
+ /* here num_dims is unsigned (mlsize_t) so no need to check (num_dims >= 0) */
+ if (num_dims > CAML_BA_MAX_NUM_DIMS)
caml_invalid_argument("Bigarray.create: bad number of dimensions");
for (i = 0; i < num_dims; i++) {
dim[i] = Long_val(Field(vdim, i));
intnat * sub_dims;
char * sub_data;
- /* Check number of indices < number of dimensions of array */
+ /* Check number of indices <= number of dimensions of array */
num_inds = Wosize_val(vind);
- if (num_inds >= b->num_dims)
+ if (num_inds > b->num_dims)
caml_invalid_argument("Bigarray.slice: too many indices");
/* Compute offset and check bounds */
if ((b->flags & CAML_BA_LAYOUT_MASK) == CAML_BA_C_LAYOUT) {
/* 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);
+ int flags = (b->flags & (CAML_BA_KIND_MASK | CAML_BA_MANAGED_MASK))
+ | Caml_ba_layout_val(vlayout);
/* reverse the dimensions */
intnat new_dim[CAML_BA_MAX_NUM_DIMS];
unsigned int i;
caml_ba_update_proxy(b, Caml_ba_array_val(res));
CAMLreturn(res);
} else {
- /* otherwise, do nothing */
- CAMLreturn(vb);
+ /* otherwise, do nothing */
+ CAMLreturn(vb);
}
#undef b
}
int i;
num_dims = Wosize_val(vdim);
- if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS)
+ /* here num_dims is unsigned (mlsize_t) so no need to check (num_dims >= 0) */
+ if (num_dims > CAML_BA_MAX_NUM_DIMS)
caml_invalid_argument("Bigarray.reshape: bad number of dimensions");
num_elts = 1;
for (i = 0; i < num_dims; i++) {
../../utils/terminfo.cmo ../../utils/warnings.cmo \
../../parsing/asttypes.cmi \
../../parsing/location.cmo ../../parsing/longident.cmo \
- ../../parsing/docstrings.cmo ../../parsing/ast_helper.cmo \
+ ../../parsing/docstrings.cmo ../../parsing/syntaxerr.cmo \
+ ../../parsing/ast_helper.cmo \
../../parsing/ast_mapper.cmo ../../parsing/ast_iterator.cmo \
../../parsing/attr_helper.cmo \
../../parsing/builtin_attributes.cmo \
INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
install:
- cp dynlink.cmi dynlink.cma dynlink.mli "$(INSTALL_LIBDIR)"
+ cp dynlink.cmi dynlink.cmti dynlink.cma dynlink.mli "$(INSTALL_LIBDIR)"
cp extract_crc "$(INSTALL_LIBDIR)/extract_crc$(EXE)"
installopt:
(* Dynamic loading of .cmx files *)
+open Cmx_format
+
type handle
-external ndl_open: string -> bool -> handle * bytes = "caml_natdynlink_open"
+type global_map = {
+ name : string;
+ crc_intf : Digest.t;
+ crc_impl : Digest.t;
+ syms : string list
+}
+
+external ndl_open: string -> bool -> handle * dynheader = "caml_natdynlink_open"
external ndl_run: handle -> string -> unit = "caml_natdynlink_run"
-external ndl_getmap: unit -> bytes = "caml_natdynlink_getmap"
+external ndl_getmap: unit -> global_map list = "caml_natdynlink_getmap"
external ndl_globals_inited: unit -> int = "caml_natdynlink_globals_inited"
type linking_error =
exception Error of error
-open Cmx_format
-
(* Copied from config.ml to avoid dependencies *)
let cmxs_magic_number = "Caml2007D002"
let dll = dll_filename filename in
if not (Sys.file_exists dll) then raise (Error (File_not_found dll));
- let (handle,data) as res = ndl_open dll (not priv) in
- if Obj.tag (Obj.repr res) = Obj.string_tag
- then raise (Error (Cannot_open_dll (Obj.magic res)));
+ let (handle,header) = try
+ ndl_open dll (not priv)
+ with Failure s -> raise (Error (Cannot_open_dll s)) in
- let header : dynheader = Marshal.from_bytes data 0 in
if header.dynu_magic <> cmxs_magic_number
then raise(Error(Not_a_bytecode_file dll));
(dll, handle, header.dynu_units)
let inited = ref false
let default_available_units () =
- let map : (string*Digest.t*Digest.t*string list) list =
- Marshal.from_bytes (ndl_getmap ()) 0 in
+ let map = ndl_getmap () in
let exe = Sys.executable_name in
let rank = ref 0 in
global_state :=
List.fold_left
- (fun st (name,crc_intf,crc_impl,syms) ->
+ (fun st {name;crc_intf;crc_impl;syms} ->
rank := !rank + List.length syms;
{
ifaces = StrMap.add name (crc_intf,exe) st.ifaces;
caml_gr_check_open();
width = Width_im(image);
height = Height_im(image);
- m = alloc(height, 0);
+ m = caml_alloc(height, 0);
for (i = 0; i < height; i++) {
- value v = alloc(width, 0);
- modify(&Field(m, i), v);
+ value v = caml_alloc(width, 0);
+ caml_modify(&Field(m, i), v);
}
idata =
static value caml_gr_wait_allocate_result(int mouse_x, int mouse_y, int button,
int keypressed, int key)
{
- value res = alloc_small(5, 0);
+ value res = caml_alloc_small(5, 0);
Field(res, 0) = Val_int(mouse_x);
Field(res, 1) = Val_int(mouse_y == -1 ? -1 : Wcvt(mouse_y));
Field(res, 2) = Val_bool(button);
/* No event available: block on input socket until one is */
FD_ZERO(&readfds);
FD_SET(ConnectionNumber(caml_gr_display), &readfds);
- enter_blocking_section();
+ caml_enter_blocking_section();
select(FD_SETSIZE, &readfds, NULL, NULL, NULL);
- leave_blocking_section();
+ caml_leave_blocking_section();
caml_gr_check_open(); /* in case another thread closed the display */
}
}
npoints, Complex, CoordModeOrigin);
XFlush(caml_gr_display);
}
- stat_free((char *) points);
+ caml_stat_free((char *) points);
return Val_unit;
}
(** Return the size of the graphics window. Coordinates of the screen
pixels range over [0 .. size_x()-1] and [0 .. size_y()-1].
Drawings outside of this rectangle are clipped, without causing
- an error. The origin (0,0) is at the lower left corner. *)
+ an error. The origin (0,0) is at the lower left corner.
+ Some implementation (e.g. X Windows) represent coordinates by
+ 16-bit integers, hence wrong clipping may occur with coordinates
+ below [-32768] or above [32676]. *)
(** {6 Colors} *)
graphics window, the [mouse_x] and [mouse_y] fields of the event are
outside the range [0..size_x()-1, 0..size_y()-1]. Keypresses
are queued, and dequeued one by one when the [Key_pressed]
- event is specified. *)
+ event is specified and the [Poll] event is not specified. *)
val loop_at_exit : event list -> (status -> unit) -> unit
(** Loop before exiting the program, the list given as argument is the
value caml_gr_new_image(int w, int h)
{
- value res = alloc_custom(&image_ops, sizeof(struct grimage),
+ value res = caml_alloc_custom(&image_ops, sizeof(struct grimage),
w * h, Max_image_mem);
Width_im(res) = w;
Height_im(res) = h;
char tmp[256];
sprintf(tmp, "%lu", (unsigned long)win);
- return copy_string( tmp );
+ return caml_copy_string( tmp );
}
value caml_gr_window_id(void)
value caml_gr_set_window_title(value n)
{
- if (window_name != NULL) stat_free(window_name);
+ if (window_name != NULL) caml_stat_free(window_name);
window_name = caml_strdup(String_val(n));
if (caml_gr_initialized) {
XStoreName(caml_gr_display, caml_gr_window.win, window_name);
if (graphic_failure_exn == NULL) {
graphic_failure_exn = caml_named_value("Graphics.Graphic_failure");
if (graphic_failure_exn == NULL)
- invalid_argument("Exception Graphics.Graphic_failure not initialized,"
+ caml_invalid_argument("Exception Graphics.Graphic_failure not initialized,"
" must link graphics.cma");
}
sprintf(buffer, fmt, arg);
- raise_with_string(*graphic_failure_exn, buffer);
+ caml_raise_with_string(*graphic_failure_exn, buffer);
}
void caml_gr_check_open(void)
value caml_gr_draw_string(value str)
{
caml_gr_check_open();
- caml_gr_draw_text(String_val(str), string_length(str));
+ caml_gr_draw_text(String_val(str), caml_string_length(str));
return Val_unit;
}
value res;
caml_gr_check_open();
if (caml_gr_font == NULL) caml_gr_get_font(DEFAULT_FONT);
- width = XTextWidth(caml_gr_font, String_val(str), string_length(str));
- res = alloc_small(2, 0);
+ width = XTextWidth(caml_gr_font, String_val(str), caml_string_length(str));
+ res = caml_alloc_small(2, 0);
Field(res, 0) = Val_int(width);
Field(res, 1) = Val_int(caml_gr_font->ascent + caml_gr_font->descent);
return res;
#* *
#**************************************************************************
-include Makefile.shared
+# 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
+
+# At the moment, the following rule only works with gcc
+# It is not a big deal since the .depend file it produces is stored
+# in the repository
depend:
$(CC) -MM $(CFLAGS) *.c > .depend
- $(CAMLRUN) ../../tools/ocamldep -slash *.mli *.ml >> .depend
+ $(CAMLRUN) $(ROOTDIR)/tools/ocamldep -slash *.mli *.ml >> .depend
+
+ifeq "$(TOOLCHAIN)" "msvc"
+
+.depend.nt: .depend
+ sed -e 's/\.o/.$(O)/g' $< > $@
+include .depend.nt
+else
include .depend
+endif
#* *
#**************************************************************************
-include Makefile.shared
-
-depend:
- sed -e 's/\.o/.$(O)/g' .depend > .depend.nt
-
-include .depend.nt
+include Makefile
+++ /dev/null
-#**************************************************************************
-#* *
-#* 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
if eq_big_int bi monster_big_int then monster_int
else failwith "int_of_big_int";;
+let int_of_big_int_opt bi =
+ try Some (int_of_big_int bi) with Failure _ -> None
+
let big_int_of_nativeint i =
if i = 0n then
zero_big_int
then Nativeint.neg i
else failwith "nativeint_of_big_int"
+let nativeint_of_big_int_opt bi =
+ try Some (nativeint_of_big_int bi) with Failure _ -> None
+
let big_int_of_int32 i = big_int_of_nativeint (Nativeint.of_int32 i)
let int32_of_big_int bi =
then Nativeint.to_int32 i
else failwith "int32_of_big_int"
+let int32_of_big_int_opt bi =
+ try Some (int32_of_big_int bi) with Failure _ -> None
+
let big_int_of_int64 i =
if Sys.word_size = 64 then
big_int_of_nativeint (Int64.to_nativeint i)
else failwith "int64_of_big_int"
end
+let int64_of_big_int_opt bi =
+ try Some (int64_of_big_int bi) with Failure _ -> None
+
(* Coercion with nat type *)
let nat_of_big_int bi =
if bi.sign = -1
let big_int_of_string s =
sys_big_int_of_string s 0 (String.length s)
+let big_int_of_string_opt s =
+ try Some (big_int_of_string s) with Failure _ -> None
+
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
(** Convert a string to a big integer, in decimal.
The string consists of an optional [-] or [+] sign,
followed by one or several decimal digits. *)
+(* TODO: document error condition. *)
+
+val big_int_of_string_opt: string -> big_int option
+(** Convert a string to a big integer, in decimal.
+ The string consists of an optional [-] or [+] sign,
+ followed by one or several decimal digits. Other the function
+ returns [None].
+ @since 4.05
+*)
+
(** {6 Conversions to and from other numerical types} *)
Raises [Failure "int_of_big_int"] if the big integer
is not representable as a small integer. *)
+val int_of_big_int_opt: big_int -> int option
+(** Convert a big integer to a small integer (type [int]). Return
+ [None] if the big integer is not representable as a small
+ integer.
+ @since 4.05
+*)
+
val big_int_of_int32 : int32 -> big_int
(** Convert a 32-bit integer to a big integer. *)
Raises [Failure] if the big integer is outside the
range \[-2{^31}, 2{^31}-1\]. *)
+val int32_of_big_int_opt: big_int -> int32 option
+(** Convert a big integer to a 32-bit integer. Return [None] if the
+ big integer is outside the range \[-2{^31}, 2{^31}-1\].
+ @since 4.05
+*)
+
val nativeint_of_big_int : big_int -> nativeint
(** Convert a big integer to a native integer.
Raises [Failure] if the big integer is outside the
range [[Nativeint.min_int, Nativeint.max_int]]. *)
+val nativeint_of_big_int_opt: big_int -> nativeint option
+(** Convert a big integer to a native integer. Return [None] if the
+ big integer is outside the range [[Nativeint.min_int,
+ Nativeint.max_int]];
+ @since 4.05
+*)
+
val int64_of_big_int : big_int -> int64
(** Convert a big integer to a 64-bit integer.
Raises [Failure] if the big integer is outside the
range \[-2{^63}, 2{^63}-1\]. *)
+val int64_of_big_int_opt: big_int -> int64 option
+(** Convert a big integer to a 64-bit integer. Return [None] if the
+ big integer is outside the range \[-2{^63}, 2{^63}-1\].
+ @since 4.05
+*)
+
val float_of_big_int : big_int -> float
(** Returns a floating-point number approximating the
given big integer. *)
val approx_big_int: int -> big_int -> string
val round_big_int_to_float: big_int -> bool -> float
-(* @since 4.03.0 *)
+(** @since 4.03.0 *)
CAMLprim value initialize_nat(value unit)
{
bng_init();
- register_custom_operations(&nat_operations);
+ caml_register_custom_operations(&nat_operations);
return Val_unit;
}
{
mlsize_t sz = Long_val(size);
- return alloc_custom(&nat_operations, sz * sizeof(value), 0, 1);
+ return caml_alloc_custom(&nat_operations, sz * sizeof(value), 0, 1);
}
CAMLprim value length_nat(value nat)
- 32-bit word: number of 32-bit words in nat
- N 32-bit words (big-endian format)
For little-endian platforms, the memory layout between 32-bit and 64-bit
- machines is identical, so we can write the nat using serialize_block_4.
+ machines is identical, so we can write the nat using caml_serialize_block_4.
For big-endian 64-bit platforms, we need to swap the two 32-bit halves
of 64-bit words to obtain the correct behavior. */
#ifdef ARCH_SIXTYFOUR
len = len * 2; /* two 32-bit words per 64-bit digit */
if (len >= ((mlsize_t)1 << 32))
- failwith("output_value: nat too big");
+ caml_failwith("output_value: nat too big");
#endif
- serialize_int_4((int32_t) len);
+ caml_serialize_int_4((int32_t) len);
#if defined(ARCH_SIXTYFOUR) && defined(ARCH_BIG_ENDIAN)
{ int32_t * p;
mlsize_t i;
for (i = len, p = Data_custom_val(nat); i > 0; i -= 2, p += 2) {
- serialize_int_4(p[1]); /* low 32 bits of 64-bit digit */
- serialize_int_4(p[0]); /* high 32 bits of 64-bit digit */
+ caml_serialize_int_4(p[1]); /* low 32 bits of 64-bit digit */
+ caml_serialize_int_4(p[0]); /* high 32 bits of 64-bit digit */
}
}
#else
- serialize_block_4(Data_custom_val(nat), len);
+ caml_serialize_block_4(Data_custom_val(nat), len);
#endif
*wsize_32 = len * 4;
*wsize_64 = len * 4;
{
mlsize_t len;
- len = deserialize_uint_4();
+ len = caml_deserialize_uint_4();
#if defined(ARCH_SIXTYFOUR) && defined(ARCH_BIG_ENDIAN)
{ uint32_t * p;
mlsize_t i;
for (i = len, p = dst; i > 1; i -= 2, p += 2) {
- p[1] = deserialize_uint_4(); /* low 32 bits of 64-bit digit */
- p[0] = deserialize_uint_4(); /* high 32 bits of 64-bit digit */
+ p[1] = caml_deserialize_uint_4(); /* low 32 bits of 64-bit digit */
+ p[0] = caml_deserialize_uint_4(); /* high 32 bits of 64-bit digit */
}
if (i > 0){
- p[1] = deserialize_uint_4(); /* low 32 bits of 64-bit digit */
+ p[1] = caml_deserialize_uint_4(); /* low 32 bits of 64-bit digit */
p[0] = 0; /* high 32 bits of 64-bit digit */
++ len;
}
}
#else
- deserialize_block_4(dst, len);
+ caml_deserialize_block_4(dst, len);
#if defined(ARCH_SIXTYFOUR)
if (len & 1){
((uint32_t *) dst)[len] = 0;
| Big_int bi -> int_of_big_int bi
| Ratio r -> int_of_ratio r
+let int_of_num_opt = function
+ Int i -> Some i
+| Big_int bi -> int_of_big_int_opt bi
+| Ratio r -> (try Some (int_of_ratio r) with Failure _ -> None)
+
and num_of_int i =
if i = monster_int
then Big_int (big_int_of_int i)
then Int (nth_digit_nat nat 0)
else Big_int (big_int_of_nat nat)
+let nat_of_num_opt x =
+ try Some (nat_of_num x) with Failure _ -> None
+
(* Coercion with big_int type *)
let big_int_of_num = function
Int i -> big_int_of_int i
| Big_int bi -> bi
| Ratio r -> big_int_of_ratio r
+let big_int_of_num_opt x =
+ try Some (big_int_of_num x) with Failure _ -> None
+
let string_of_big_int_for_num bi =
if !approx_printing_flag
then approx_big_int !floating_precision bi
| Ratio r -> string_of_ratio r
let string_of_num n =
string_of_normalized_num (cautious_normalize_num_when_printing n)
+
let num_of_string s =
try
let flag = !normalize_ratio_flag in
with Failure _ ->
failwith "num_of_string"
+let num_of_string_opt s =
+ try Some (num_of_string s) with Failure _ -> None
+
(* Coercion with float type *)
let float_of_num = function
Int i -> float i
Raise [Failure "num_of_string"] if the given string is not
a valid representation of an integer *)
+val num_of_string_opt: string -> num option
+(** Convert a string to a number.
+ Return [None] if the given string is not
+ a valid representation of an integer.
+
+ @since 4.05
+*)
+
(** {6 Coercions between numerical types} *)
+(* TODO: document the functions below (truncating behavior and error conditions). *)
+
val int_of_num : num -> int
+val int_of_num_opt: num -> int option
+(** @since 4.05.0 *)
+
val num_of_int : int -> num
val nat_of_num : num -> nat
+val nat_of_num_opt: num -> nat option
+(** @since 4.05.0 *)
+
val num_of_nat : nat -> num
val num_of_big_int : big_int -> num
val big_int_of_num : num -> big_int
+val big_int_of_num_opt: num -> big_int option
+(** @since 4.05.0 *)
+
val ratio_of_num : num -> ratio
val num_of_ratio : ratio -> num
val float_of_num : num -> float
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 :
#* *
#**************************************************************************
-# Common Makefile for otherlibs on the Unix ports
+# Makefile for Raw_spacetime_lib
+ROOTDIR=../..
+include $(ROOTDIR)/config/Makefile
+
+CAMLRUN ?= $(ROOTDIR)/boot/ocamlrun
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)
+# The remainder of this file could probably be simplified by including
+# ../Makefile.
+
+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) $(ROOTDIR)/tools/ocamldep *.mli *.ml >> .depend
+
+include .depend
#* *
#**************************************************************************
-# 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)
+++ /dev/null
-#**************************************************************************
-#* *
-#* 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
strstubs.o: strstubs.c ../../byterun/caml/mlvalues.h \
- ../../byterun/caml/config.h ../../byterun/caml/../../config/m.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/fail.h
#* *
#**************************************************************************
-include Makefile.shared
+# 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) $(ROOTDIR)/tools/ocamldep -slash *.mli *.ml >> .depend
+
+ifeq "$(TOOLCHAIN)" "msvc"
+
+.depend.nt: .depend
+ sed -e 's/\.o/.$(O)/g' $< > $@
+
+include .depend.nt
+else
+include .depend
+endif
#* *
#**************************************************************************
-include Makefile.shared
-
-.depend.nt: .depend
- sed -e 's/\.o/.$(O)/g' .depend > .depend.nt
-
-include .depend.nt
+include Makefile
+++ /dev/null
-#**************************************************************************
-#* *
-#* 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
(* *)
(**************************************************************************)
-(* In this module, [@ocaml.warnerror "-3"] is used in several places
+(* In this module, [@ocaml.warning "-3"] is used in several places
that use deprecated functions to preserve legacy behavior.
It overrides -w @3 given on the command line. *)
let fold_case s =
(let r = make_empty() in
iter (fun c -> add r (Char.lowercase c); add r (Char.uppercase c)) s;
- r)[@ocaml.warnerror "-3"]
+ r)[@ocaml.warning "-3"]
end
let fold_case_table =
(let t = Bytes.create 256 in
for i = 0 to 255 do Bytes.set t i (Char.lowercase(Char.chr i)) done;
- Bytes.to_string t)[@ocaml.warnerror "-3"]
+ Bytes.to_string t)[@ocaml.warning "-3"]
module StringMap =
Map.Make(struct type t = string let compare (x:t) y = compare x y end)
incr progpos in
(* Reserve an instruction slot and return its position *)
let emit_hole () =
- let p = !progpos in incr progpos; p in
+ let p = !progpos in emit_instr op_CHAR 0; p in
(* Fill a reserved instruction slot with a GOTO or PUSHBACK instruction *)
let patch_instr pos opc dest =
(!prog).(pos) <- (instr opc (displ dest pos)) in
Char c ->
if fold_case then
emit_instr op_CHARNORM (Char.code (Char.lowercase c))
- [@ocaml.warnerror "-3"]
+ [@ocaml.warning "-3"]
else
emit_instr op_CHAR (Char.code c)
| String s ->
| 1 ->
if fold_case then
emit_instr op_CHARNORM (Char.code (Char.lowercase s.[0]))
- [@ocaml.warnerror "-3"]
+ [@ocaml.warning "-3"]
else
emit_instr op_CHAR (Char.code s.[0])
| _ ->
with Not_found ->
if fold_case then
emit_instr op_STRINGNORM (cpool_index (String.lowercase s))
- [@ocaml.warnerror "-3"]
+ [@ocaml.warning "-3"]
else
emit_instr op_STRING (cpool_index s)
end
/* */
/**************************************************************************/
-#define CAML_NAME_SPACE
#include <string.h>
#include <ctype.h>
#include <caml/mlvalues.h>
#* *
#**************************************************************************
-include ../../config/Makefile
-CAMLRUN ?= ../../boot/ocamlrun
-CAMLYACC ?= ../../boot/ocamlyacc
-
ROOTDIR=../..
-CAMLC=$(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib \
- -I $(ROOTDIR)/stdlib -I $(ROOTDIR)/otherlibs/unix
-CAMLOPT=$(CAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib \
- -I $(ROOTDIR)/stdlib -I $(ROOTDIR)/otherlibs/unix
-MKLIB=$(CAMLRUN) ../../tools/ocamlmklib
+
+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
+
+LIBS = -nostdlib -I $(ROOTDIR)/stdlib -I $(ROOTDIR)/otherlibs/$(UNIXLIB)
+
+CAMLC=$(CAMLRUN) $(ROOTDIR)/ocamlc $(LIBS)
+CAMLOPT=$(CAMLRUN) $(ROOTDIR)/ocamlopt $(LIBS)
+MKLIB=$(CAMLRUN) $(ROOTDIR)/tools/ocamlmklib
COMPFLAGS=-w +33..39 -warn-error A -g -bin-annot -safe-string
ifeq "$(FLAMBDA)" "true"
OPTCOMPFLAGS=-O3
OPTCOMPFLAGS=
endif
-BYTECODE_C_OBJS=st_stubs_b.o
-NATIVECODE_C_OBJS=st_stubs_n.o
+LIBNAME=threads
-THREAD_OBJS= thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo
+ifeq "$(UNIX_OR_WIN32)" "unix"
+HEADER = st_posix.h
+else # Windows
+HEADER = st_win32.h
+endif
-all: libthreads.a threads.cma
+BYTECODE_C_OBJS=st_stubs_b.$(O)
+NATIVECODE_C_OBJS=st_stubs_n.$(O)
-allopt: libthreadsnat.a threads.cmxa
+THREADS_SOURCES = thread.ml mutex.ml condition.ml event.ml threadUnix.ml
-libthreads.a: $(BYTECODE_C_OBJS)
- $(MKLIB) -o threads $(BYTECODE_C_OBJS) $(PTHREAD_LINK)
+THREADS_BCOBJS = $(THREADS_SOURCES:.ml=.cmo)
+THREADS_NCOBJS = $(THREADS_SOURCES:.ml=.cmx)
-st_stubs_b.o: st_stubs.c st_posix.h
- $(BYTECC) -I../../byterun $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) \
- -c st_stubs.c
- mv st_stubs.o st_stubs_b.o
+MLIFILES=thread.mli mutex.mli condition.mli event.mli threadUnix.mli
+CMIFILES=$(MLIFILES:.mli=.cmi)
-# Dynamic linking with -lpthread is risky on many platforms, so
-# do not create a shared object for libthreadsnat.
-libthreadsnat.a: $(NATIVECODE_C_OBJS)
- $(AR) rc libthreadsnat.a $(NATIVECODE_C_OBJS)
+all: lib$(LIBNAME).$(A) $(LIBNAME).cma $(CMIFILES)
-st_stubs_n.o: st_stubs.c st_posix.h
- $(NATIVECC) -I../../asmrun -I../../byterun $(NATIVECCCOMPOPTS) \
- $(SHAREDCCCOMPOPTS) -DNATIVE_CODE -DTARGET_$(ARCH) \
- -DMODEL_$(MODEL) -DSYS_$(SYSTEM) -c st_stubs.c
- mv st_stubs.o st_stubs_n.o
+allopt: lib$(LIBNAME)nat.$(A) $(LIBNAME).cmxa $(CMIFILES)
-threads.cma: $(THREAD_OBJS)
- $(MKLIB) -ocamlc '$(CAMLC)' -o threads $(THREAD_OBJS) \
- -cclib -lunix $(PTHREAD_CAML_LINK)
+lib$(LIBNAME).$(A): $(BYTECODE_C_OBJS)
+ $(MKLIB) -o $(LIBNAME) $(BYTECODE_C_OBJS) $(PTHREAD_LINK)
+
+lib$(LIBNAME)nat.$(A): $(NATIVECODE_C_OBJS)
+ $(MKLIB) -o $(LIBNAME)nat $^
+
+$(LIBNAME).cma: $(THREADS_BCOBJS)
+ifeq "$(UNIX_OR_WIN32)" "unix"
+ $(MKLIB) -o $(LIBNAME) -ocamlc '$(CAMLC)' -cclib -lunix -linkall $(PTHREAD_CAML_LINK) $^
+# TODO: Figure out why -cclib -lunix is used here.
+# It may be because of the threadsUnix module which is deprecated.
+# It may hence be good to figure out whether this module shouldn't be
+# removed, and then -cclib -lunix arguments.
+else # Windows
+ $(MKLIB) -o $(LIBNAME) -ocamlc "$(CAMLC)" -linkall $(PTHREAD_CAML_LINK) $^
+endif
# See remark above: force static linking of libthreadsnat.a
-threads.cmxa: $(THREAD_OBJS:.cmo=.cmx)
- $(CAMLOPT) -a -o threads.cmxa $(THREAD_OBJS:.cmo=.cmx) \
- -cclib -lthreadsnat $(PTHREAD_CAML_LINK)
+$(LIBNAME).cmxa: $(THREADS_NCOBJS)
+ $(CAMLOPT) -linkall -a -cclib -lthreadsnat $(PTHREAD_CAML_LINK) -o $@ $^
# Note: I removed "-cclib -lunix" from the line above.
# Indeed, if we link threads.cmxa, then we must also link unix.cmxa,
# which itself will pass -lunix to the C linker. It seems more
# modular to me this way. -- Alain
+# The following lines produce two object files st_stubs_b.$(O) and
+# st_stubs_n.$(O) from the same source file st_stubs.c (it is compiled
+# twice, each time with different of options).
+# Since the source and object file have a different basename, the name of
+# the object file to produce must be given to the C compiler.
+# For gcc this is done with the -ofoo.$(O) option.
+# For msvc it's the /Fofoo.$(O) option.
+
+ifeq "$(TOOLCHAIN)" "msvc"
+ CCOUTPUT=/Fo
+else
+ CCOUTPUT=-o
+endif
-$(THREAD_OBJS:.cmo=.cmx): ../../ocamlopt
+st_stubs_b.$(O): st_stubs.c $(HEADER)
+ $(BYTECC) -I$(ROOTDIR)/byterun $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) \
+ $(CCOUTPUT)$@ -c $<
+
+st_stubs_n.$(O): st_stubs.c $(HEADER)
+ $(NATIVECC) -I$(ROOTDIR)/asmrun -I$(ROOTDIR)/byterun \
+ $(NATIVECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -DNATIVE_CODE \
+ -DTARGET_$(ARCH) -DMODEL_$(MODEL) -DSYS_$(SYSTEM) \
+ $(CCOUTPUT)$@ -c $<
partialclean:
rm -f *.cm*
clean: partialclean
- rm -f *.o *.a *.so
+ rm -f dllthreads*$(EXT_DLL) *.$(A) *.$(O)
INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
+THREADS_LIBDIR=$(INSTALL_LIBDIR)/$(LIBNAME)
INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR)
install:
- if test -f dllthreads.so; then \
- cp dllthreads.so $(INSTALL_STUBLIBDIR)/dllthreads.so; fi
- cp libthreads.a $(INSTALL_LIBDIR)/libthreads.a
- cd $(INSTALL_LIBDIR); $(RANLIB) libthreads.a
- if test -d $(INSTALL_LIBDIR)/threads; then :; \
- else mkdir $(INSTALL_LIBDIR)/threads; fi
- cp $(THREAD_OBJS:.cmo=.cmi) threads.cma $(INSTALL_LIBDIR)/threads
- rm -f $(INSTALL_LIBDIR)/threads/stdlib.cma
- cp thread.mli mutex.mli condition.mli event.mli threadUnix.mli \
- $(INSTALL_LIBDIR)
- cp threads.h $(INSTALL_LIBDIR)/caml/threads.h
+ if test -f dllthreads$(EXT_DLL); then \
+ cp dllthreads$(EXT_DLL) "$(INSTALL_STUBLIBDIR)/dllthreads$(EXT_DLL)"; fi
+ cp libthreads.$(A) "$(INSTALL_LIBDIR)"
+ cd "$(INSTALL_LIBDIR)"; $(RANLIB) libthreads.$(A)
+ mkdir -p "$(THREADS_LIBDIR)"
+ cp $(CMIFILES) $(CMIFILES:.cmi=.cmti) threads.cma "$(THREADS_LIBDIR)"
+ cp $(MLIFILES) "$(INSTALL_LIBDIR)"
+ cp threads.h "$(INSTALL_LIBDIR)/caml"
installopt:
- cp libthreadsnat.a $(INSTALL_LIBDIR)/libthreadsnat.a
- cd $(INSTALL_LIBDIR); $(RANLIB) libthreadsnat.a
- cp $(THREAD_OBJS:.cmo=.cmx) threads.cmxa threads.a \
- $(INSTALL_LIBDIR)/threads
- cd $(INSTALL_LIBDIR)/threads && $(RANLIB) threads.a
+ cp libthreadsnat.$(A) "$(INSTALL_LIBDIR)"
+ cd "$(INSTALL_LIBDIR)"; $(RANLIB) libthreadsnat.$(A)
+ cp $(THREADS_NCOBJS) threads.cmxa threads.$(A) "$(THREADS_LIBDIR)"
+ cd "$(THREADS_LIBDIR)" && $(RANLIB) threads.$(A)
.SUFFIXES: .ml .mli .cmo .cmi .cmx
.ml.cmx:
$(CAMLOPT) -c $(COMPFLAGS) $(OPTCOMPFLAGS) $<
+ifeq "$(UNIX_OR_WIN32)" "unix"
depend: $(GENFILES)
-$(CC) -MM -I../../byterun *.c > .depend
$(CAMLRUN) ../../tools/ocamldep -slash *.mli *.ml >> .depend
+else # Windows
+depend:
+endif
include .depend
#* *
#**************************************************************************
-include ../../config/Makefile
-CAMLRUN ?= ../../boot/ocamlrun
-CAMLYACC ?= ../../boot/ocamlyacc
-
-# Compilation options
-CAMLC=$(CAMLRUN) ../../ocamlc -I ../../stdlib -I ../win32unix
-CAMLOPT=$(CAMLRUN) ../../ocamlopt -I ../../stdlib -I ../win32unix
-COMPFLAGS=-w +33 -warn-error A -g
-ifeq "$(FLAMBDA)" "true"
-OPTCOMPFLAGS=-O3
-else
-OPTCOMPFLAGS=
-endif
-MKLIB=$(CAMLRUN) ../../tools/ocamlmklib
-CFLAGS=-I../../byterun $(EXTRACFLAGS)
-
-ifeq "$(wildcard ../../flexdll/Makefile)" ""
- export OCAML_FLEXLINK:=
-else
- export OCAML_FLEXLINK:=../../boot/ocamlrun ../../flexdll/flexlink.exe
-endif
-
-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)
-
-LIBNAME=threads
-
-all: lib$(LIBNAME).$(A) $(LIBNAME).cma $(CMIFILES)
-
-allopt: lib$(LIBNAME).$(A) $(LIBNAME).cmxa $(LIBNAME).cmxs $(CMIFILES)
-
-$(LIBNAME).cma: $(THREAD_OBJS)
- $(MKLIB) -o $(LIBNAME) -ocamlc "$(CAMLRUN) ../../ocamlc" \
- -linkall $(THREAD_OBJS) $(LINKOPTS)
-
-lib$(LIBNAME).$(A): $(COBJS)
- $(MKLIB) -o $(LIBNAME) $(COBJS) $(LDOPTS)
-
-st_stubs_b.$(O): st_stubs.c st_win32.h
- $(BYTECC) $(BYTECCCOMPOPTS) $(CFLAGS) -c st_stubs.c
- mv st_stubs.$(O) st_stubs_b.$(O)
-
-
-
-$(LIBNAME).cmxa: $(THREAD_OBJS:.cmo=.cmx)
- $(MKLIB) -o $(LIBNAME)nat \
- -ocamlopt "$(CAMLRUN) ../../ocamlopt" -linkall \
- $(THREAD_OBJS:.cmo=.cmx) $(LINKOPTS)
- mv $(LIBNAME)nat.cmxa $(LIBNAME).cmxa
- mv $(LIBNAME)nat.$(A) $(LIBNAME).$(A)
-
-$(LIBNAME).cmxs: $(LIBNAME).cmxa lib$(LIBNAME)nat.$(A)
- $(CAMLOPT) -shared -o $(LIBNAME).cmxs -I . $(LIBNAME).cmxa -linkall
-
-lib$(LIBNAME)nat.$(A): $(COBJS_NAT)
- $(MKLIB) -o $(LIBNAME)nat $(COBJS_NAT) $(LDOPTS)
-
-st_stubs_n.$(O): st_stubs.c st_win32.h
- $(NATIVECC) -DNATIVE_CODE -I../../asmrun -I../../byterun \
- $(NATIVECCCOMPOPTS) -c st_stubs.c
- mv st_stubs.$(O) st_stubs_n.$(O)
-
-$(THREAD_OBJS:.cmo=.cmx): ../../ocamlopt
-
-partialclean:
- rm -f *.cm*
-
-clean: partialclean
- rm -f *.dll *.$(A) *.$(O)
-
-INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
-INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR)
-
-install:
- cp dllthreads.dll "$(INSTALL_STUBLIBDIR)/dllthreads.dll"
- cp libthreads.$(A) "$(INSTALL_LIBDIR)/libthreads.$(A)"
- mkdir -p "$(INSTALL_LIBDIR)/threads"
- cp $(CMIFILES) threads.cma "$(INSTALL_LIBDIR)/threads"
- rm -f "$(INSTALL_LIBDIR)/threads/stdlib.cma"
- cp threads.h "$(INSTALL_LIBDIR)/caml/threads.h"
-
-installopt:
- cp libthreadsnat.$(A) "$(INSTALL_LIBDIR)/libthreadsnat.$(A)"
- cp $(THREAD_OBJS:.cmo=.cmx) threads.cmxa threads.$(A) \
- "$(INSTALL_LIBDIR)/threads"
- cp threads.cmxs "$(INSTALL_LIBDIR)/threads"
-
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-
-.mli.cmi:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLC) -c -g $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $(OPTCOMPFLAGS) $<
-
-depend:
-
-include .depend
+include Makefile
Condition.wait c m
done;
(* Modify D *)
- if (* the predicate P over D is now satified *) then Condition.signal c;
+ if (* the predicate P over D is now satisfied *) then Condition.signal c;
Mutex.unlock m
]}
*)
value str;
if (retcode == 0) return;
- if (retcode == ENOMEM) raise_out_of_memory();
+ if (retcode == ENOMEM) caml_raise_out_of_memory();
err = strerror(retcode);
msglen = strlen(msg);
errlen = strlen(err);
- str = alloc_string(msglen + 2 + errlen);
+ str = caml_alloc_string(msglen + 2 + errlen);
memmove (&Byte(str, 0), msg, msglen);
memmove (&Byte(str, msglen), ": ", 2);
memmove (&Byte(str, msglen + 2), err, errlen);
- raise_sys_error(str);
+ caml_raise_sys_error(str);
}
/* Variable used to stop the "tick" thread */
Begin_root(res)
for (i = 1; i < NSIG; i++)
if (sigismember(set, i) > 0) {
- value newcons = alloc_small(2, 0);
+ value newcons = caml_alloc_small(2, 0);
Field(newcons, 0) = Val_int(caml_rev_convert_signal_number(i));
Field(newcons, 1) = res;
res = newcons;
how = sigmask_cmd[Int_val(cmd)];
st_decode_sigset(sigs, &set);
- enter_blocking_section();
+ caml_enter_blocking_section();
retcode = pthread_sigmask(how, &set, &oldset);
- leave_blocking_section();
+ caml_leave_blocking_section();
st_check_error(retcode, "Thread.sigmask");
return st_encode_sigset(&oldset);
}
int retcode, signo;
st_decode_sigset(sigs, &set);
- enter_blocking_section();
+ caml_enter_blocking_section();
retcode = sigwait(&set, &signo);
- leave_blocking_section();
+ caml_leave_blocking_section();
st_check_error(retcode, "Thread.wait_signal");
return Val_int(caml_rev_convert_signal_number(signo));
#else
- invalid_argument("Thread.wait_signal not implemented");
+ caml_invalid_argument("Thread.wait_signal not implemented");
return Val_int(0); /* not reached */
#endif
}
#include "threads.h"
#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
-#include "../../asmrun/spacetime.h"
+#include "caml/spacetime.h"
#endif
/* Initial size of bytecode stack when a thread is created (4 Ko) */
value * stack_low; /* The execution stack for this thread */
value * stack_high;
value * stack_threshold;
- value * sp; /* Saved value of extern_sp for this thread */
- value * trapsp; /* Saved value of trapsp for this thread */
- struct caml__roots_block * local_roots; /* Saved value of local_roots */
- struct longjmp_buffer * external_raise; /* Saved external_raise */
+ value * sp; /* Saved value of caml_extern_sp for this thread */
+ value * trapsp; /* Saved value of caml_trapsp for this thread */
+ struct caml__roots_block * local_roots; /* Saved value of caml_local_roots */
+ struct longjmp_buffer * external_raise; /* Saved caml_external_raise */
#endif
- int backtrace_pos; /* Saved backtrace_pos */
- backtrace_slot * backtrace_buffer; /* Saved backtrace_buffer */
- value backtrace_last_exn; /* Saved backtrace_last_exn (root) */
+ int backtrace_pos; /* Saved caml_backtrace_pos */
+ backtrace_slot * backtrace_buffer; /* Saved caml_backtrace_buffer */
+ value backtrace_last_exn; /* Saved caml_backtrace_last_exn (root) */
};
typedef struct caml_thread_struct * caml_thread_t;
if (th != curr_thread) {
#ifdef NATIVE_CODE
if (th->bottom_of_stack != NULL)
- do_local_roots(action, th->bottom_of_stack, th->last_retaddr,
+ caml_do_local_roots(action, th->bottom_of_stack, th->last_retaddr,
th->gc_regs, th->local_roots);
#else
- do_local_roots(action, th->sp, th->stack_high, th->local_roots);
+ caml_do_local_roots(action, th->sp, th->stack_high, th->local_roots);
#endif
}
th = th->next;
static inline void caml_thread_save_runtime_state(void)
{
#ifdef NATIVE_CODE
+ curr_thread->top_of_stack = caml_top_of_stack;
curr_thread->bottom_of_stack = caml_bottom_of_stack;
curr_thread->last_retaddr = caml_last_return_address;
curr_thread->gc_regs = caml_gc_regs;
curr_thread->exception_pointer = caml_exception_pointer;
- curr_thread->local_roots = local_roots;
+ curr_thread->local_roots = caml_local_roots;
#ifdef WITH_SPACETIME
curr_thread->spacetime_trie_node_ptr
= caml_spacetime_trie_node_ptr;
= caml_spacetime_finaliser_trie_root;
#endif
#else
- curr_thread->stack_low = stack_low;
- curr_thread->stack_high = stack_high;
- curr_thread->stack_threshold = stack_threshold;
- curr_thread->sp = extern_sp;
- curr_thread->trapsp = trapsp;
- curr_thread->local_roots = local_roots;
- curr_thread->external_raise = external_raise;
+ curr_thread->stack_low = caml_stack_low;
+ curr_thread->stack_high = caml_stack_high;
+ curr_thread->stack_threshold = caml_stack_threshold;
+ curr_thread->sp = caml_extern_sp;
+ curr_thread->trapsp = caml_trapsp;
+ curr_thread->local_roots = caml_local_roots;
+ curr_thread->external_raise = caml_external_raise;
#endif
- curr_thread->backtrace_pos = backtrace_pos;
- curr_thread->backtrace_buffer = backtrace_buffer;
- curr_thread->backtrace_last_exn = backtrace_last_exn;
+ curr_thread->backtrace_pos = caml_backtrace_pos;
+ curr_thread->backtrace_buffer = caml_backtrace_buffer;
+ curr_thread->backtrace_last_exn = caml_backtrace_last_exn;
}
static inline void caml_thread_restore_runtime_state(void)
{
#ifdef NATIVE_CODE
+ caml_top_of_stack = curr_thread->top_of_stack;
caml_bottom_of_stack= curr_thread->bottom_of_stack;
caml_last_return_address = curr_thread->last_retaddr;
caml_gc_regs = curr_thread->gc_regs;
caml_exception_pointer = curr_thread->exception_pointer;
- local_roots = curr_thread->local_roots;
+ caml_local_roots = curr_thread->local_roots;
#ifdef WITH_SPACETIME
caml_spacetime_trie_node_ptr
= curr_thread->spacetime_trie_node_ptr;
= curr_thread->spacetime_finaliser_trie_root;
#endif
#else
- stack_low = curr_thread->stack_low;
- stack_high = curr_thread->stack_high;
- stack_threshold = curr_thread->stack_threshold;
- extern_sp = curr_thread->sp;
- trapsp = curr_thread->trapsp;
- local_roots = curr_thread->local_roots;
- external_raise = curr_thread->external_raise;
+ caml_stack_low = curr_thread->stack_low;
+ caml_stack_high = curr_thread->stack_high;
+ caml_stack_threshold = curr_thread->stack_threshold;
+ caml_extern_sp = curr_thread->sp;
+ caml_trapsp = curr_thread->trapsp;
+ caml_local_roots = curr_thread->local_roots;
+ caml_external_raise = curr_thread->external_raise;
#endif
- backtrace_pos = curr_thread->backtrace_pos;
- backtrace_buffer = curr_thread->backtrace_buffer;
- backtrace_last_exn = curr_thread->backtrace_last_exn;
+ caml_backtrace_pos = curr_thread->backtrace_pos;
+ caml_backtrace_buffer = curr_thread->backtrace_buffer;
+ caml_backtrace_last_exn = curr_thread->backtrace_last_exn;
}
-/* Hooks for enter_blocking_section and leave_blocking_section */
+/* Hooks for caml_enter_blocking_section and caml_leave_blocking_section */
static void caml_thread_enter_blocking_section(void)
static void caml_io_mutex_free(struct channel *chan)
{
st_mutex mutex = chan->mutex;
- if (mutex != NULL) st_mutex_destroy(mutex);
+ if (mutex != NULL) {
+ st_mutex_destroy(mutex);
+ chan->mutex = NULL;
+ }
}
static void caml_io_mutex_lock(struct channel *chan)
return;
}
/* If unsuccessful, block on mutex */
- enter_blocking_section();
+ caml_enter_blocking_section();
st_mutex_lock(mutex);
/* Problem: if a signal occurs at this point,
and the signal handler raises an exception, we will not
before locking the mutex is also incorrect, since we could
then unlock a mutex that is unlocked or locked by someone else. */
st_tls_set(last_channel_locked_key, (void *) chan);
- leave_blocking_section();
+ caml_leave_blocking_section();
}
static void caml_io_mutex_unlock(struct channel *chan)
th != curr_thread;
th = th->next) {
#ifdef NATIVE_CODE
- sz += (value *) th->top_of_stack - (value *) th->bottom_of_stack;
+ if(th->top_of_stack != NULL && th->bottom_of_stack != NULL &&
+ th->top_of_stack > th->bottom_of_stack)
+ sz += (value *) th->top_of_stack - (value *) th->bottom_of_stack;
#else
sz += th->stack_high - th->sp;
#endif
/* Create and initialize the termination semaphore */
mu = caml_threadstatus_new();
/* Create a descriptor for the new thread */
- descr = alloc_small(3, 0);
+ descr = caml_alloc_small(3, 0);
Ident(descr) = Val_long(thread_next_ident);
Start_closure(descr) = clos;
Terminated(descr) = mu;
th->next->prev = th->prev;
th->prev->next = th->next;
#ifndef NATIVE_CODE
- stat_free(th->stack_low);
+ caml_stat_free(th->stack_low);
#endif
if (th->backtrace_buffer != NULL) free(th->backtrace_buffer);
#ifndef WITH_SPACETIME
- stat_free(th);
+ caml_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
thr = curr_thread->next;
while (thr != curr_thread) {
next = thr->next;
- stat_free(thr);
+ caml_stat_free(thr);
thr = next;
}
curr_thread->next = curr_thread;
all_threads = curr_thread;
/* Reinitialize the master lock machinery,
just in case the fork happened while other threads were doing
- leave_blocking_section */
+ caml_leave_blocking_section */
st_masterlock_init(&caml_master_lock);
/* Tick thread is not currently running in child process, will be
re-created at next Thread.create */
curr_thread->exit_buf = &caml_termination_jmpbuf;
#endif
/* The stack-related fields will be filled in at the next
- enter_blocking_section */
+ caml_enter_blocking_section */
/* Associate the thread descriptor with the thread */
st_tls_set(thread_descriptor_key, (void *) curr_thread);
/* Set up the hooks */
- prev_scan_roots_hook = scan_roots_hook;
- scan_roots_hook = caml_thread_scan_roots;
- enter_blocking_section_hook = caml_thread_enter_blocking_section;
- leave_blocking_section_hook = caml_thread_leave_blocking_section;
- try_leave_blocking_section_hook = caml_thread_try_leave_blocking_section;
+ prev_scan_roots_hook = caml_scan_roots_hook;
+ caml_scan_roots_hook = caml_thread_scan_roots;
+ caml_enter_blocking_section_hook = caml_thread_enter_blocking_section;
+ caml_leave_blocking_section_hook = caml_thread_leave_blocking_section;
+ caml_try_leave_blocking_section_hook = caml_thread_try_leave_blocking_section;
#ifdef NATIVE_CODE
caml_termination_hook = st_thread_exit;
#endif
/* Associate the thread descriptor with the thread */
st_tls_set(thread_descriptor_key, (void *) th);
/* Acquire the global mutex */
- leave_blocking_section();
+ caml_leave_blocking_section();
#ifdef NATIVE_CODE
/* Record top of stack (approximative) */
th->top_of_stack = &tos;
#endif
/* Callback the closure */
clos = Start_closure(th->descr);
- modify(&(Start_closure(th->descr)), Val_unit);
- callback_exn(clos, Val_unit);
+ caml_modify(&(Start_closure(th->descr)), Val_unit);
+ caml_callback_exn(clos, Val_unit);
caml_thread_stop();
#ifdef NATIVE_CODE
}
/* Release the master lock */
st_masterlock_release(&caml_master_lock);
/* Now we can re-enter the run-time system and heap-allocate the descriptor */
- leave_blocking_section();
+ caml_leave_blocking_section();
th->descr = caml_thread_new_descriptor(Val_unit); /* no closure */
/* Create the tick thread if not already done. */
if (! caml_tick_thread_running) {
if (err == 0) caml_tick_thread_running = 1;
}
/* Exit the run-time system */
- enter_blocking_section();
+ caml_enter_blocking_section();
return 1;
}
CAMLprim value caml_thread_self(value unit) /* ML */
{
- if (curr_thread == NULL) invalid_argument("Thread.self: not initialized");
+ if (curr_thread == NULL) caml_invalid_argument("Thread.self: not initialized");
return curr_thread->descr;
}
CAMLprim value caml_thread_uncaught_exception(value exn) /* ML */
{
- char * msg = format_caml_exception(exn);
+ char * msg = caml_format_exception(exn);
fprintf(stderr, "Thread %d killed on uncaught exception %s\n",
Int_val(Ident(curr_thread->descr)), msg);
free(msg);
- if (caml_backtrace_active) print_exception_backtrace();
+ if (caml_backtrace_active) caml_print_exception_backtrace();
fflush(stderr);
return Val_unit;
}
{
struct longjmp_buffer * exit_buf = NULL;
- if (curr_thread == NULL) invalid_argument("Thread.exit: not initialized");
+ if (curr_thread == NULL) caml_invalid_argument("Thread.exit: not initialized");
/* In native code, we cannot call pthread_exit here because on some
systems this raises a C++ exception, and ocamlopt-generated stack
CAMLprim value caml_thread_yield(value unit) /* ML */
{
if (st_masterlock_waiters(&caml_master_lock) == 0) return Val_unit;
- enter_blocking_section();
+ caml_enter_blocking_section();
st_thread_yield();
- leave_blocking_section();
+ caml_leave_blocking_section();
return Val_unit;
}
/* Mutex operations */
#define Mutex_val(v) (* ((st_mutex *) Data_custom_val(v)))
-#define Max_mutex_number 5000
static void caml_mutex_finalize(value wrapper)
{
st_mutex mut = NULL; /* suppress warning */
value wrapper;
st_check_error(st_mutex_create(&mut), "Mutex.create");
- wrapper = alloc_custom(&caml_mutex_ops, sizeof(st_mutex *),
- 1, Max_mutex_number);
+ wrapper = caml_alloc_custom(&caml_mutex_ops, sizeof(st_mutex *),
+ 0, 1);
Mutex_val(wrapper) = mut;
return wrapper;
}
if (st_mutex_trylock(mut) == PREVIOUSLY_UNLOCKED) return Val_unit;
/* If unsuccessful, block on mutex */
Begin_root(wrapper) /* prevent the deallocation of mutex */
- enter_blocking_section();
+ caml_enter_blocking_section();
retcode = st_mutex_lock(mut);
- leave_blocking_section();
+ caml_leave_blocking_section();
End_roots();
st_check_error(retcode, "Mutex.lock");
return Val_unit;
/* Conditions operations */
#define Condition_val(v) (* (st_condvar *) Data_custom_val(v))
-#define Max_condition_number 5000
static void caml_condition_finalize(value wrapper)
{
st_condvar cond = NULL; /* suppress warning */
value wrapper;
st_check_error(st_condvar_create(&cond), "Condition.create");
- wrapper = alloc_custom(&caml_condition_ops, sizeof(st_condvar *),
- 1, Max_condition_number);
+ wrapper = caml_alloc_custom(&caml_condition_ops, sizeof(st_condvar *),
+ 0, 1);
Condition_val(wrapper) = cond;
return wrapper;
}
st_retcode retcode;
Begin_roots2(wcond, wmut) /* prevent deallocation of cond and mutex */
- enter_blocking_section();
+ caml_enter_blocking_section();
retcode = st_condvar_wait(cond, mut);
- leave_blocking_section();
+ caml_leave_blocking_section();
End_roots();
st_check_error(retcode, "Condition.wait");
return Val_unit;
/* Thread status blocks */
#define Threadstatus_val(v) (* ((st_event *) Data_custom_val(v)))
-#define Max_threadstatus_number 500
static void caml_threadstatus_finalize(value wrapper)
{
st_event ts = NULL; /* suppress warning */
value wrapper;
st_check_error(st_event_create(&ts), "Thread.create");
- wrapper = alloc_custom(&caml_threadstatus_ops, sizeof(st_event *),
- 1, Max_threadstatus_number);
+ wrapper = caml_alloc_custom(&caml_threadstatus_ops, sizeof(st_event *),
+ 0, 1);
Threadstatus_val(wrapper) = ts;
return wrapper;
}
st_retcode retcode;
Begin_roots1(wrapper) /* prevent deallocation of ts */
- enter_blocking_section();
+ caml_enter_blocking_section();
retcode = st_event_wait(ts);
- leave_blocking_section();
+ caml_leave_blocking_section();
End_roots();
return retcode;
}
/* Win32 implementation of the "st" interface */
+#undef _WIN32_WINNT
#define _WIN32_WINNT 0x0400
#include <windows.h>
#include <winerror.h>
value str;
if (retcode == 0) return;
- if (retcode == ERROR_NOT_ENOUGH_MEMORY) raise_out_of_memory();
+ if (retcode == ERROR_NOT_ENOUGH_MEMORY) caml_raise_out_of_memory();
if (! FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS,
NULL,
retcode,
}
msglen = strlen(msg);
errlen = strlen(err);
- str = alloc_string(msglen + 2 + errlen);
+ str = caml_alloc_string(msglen + 2 + errlen);
memmove (&Byte(str, 0), msg, msglen);
memmove (&Byte(str, msglen), ": ", 2);
memmove (&Byte(str, msglen + 2), err, errlen);
- raise_sys_error(str);
+ caml_raise_sys_error(str);
}
/* Variable used to stop the "tick" thread */
value caml_thread_sigmask(value cmd, value sigs) /* ML */
{
- invalid_argument("Thread.sigmask not implemented");
+ caml_invalid_argument("Thread.sigmask not implemented");
return Val_int(0); /* not reached */
}
value caml_wait_signal(value sigs) /* ML */
{
- invalid_argument("Thread.wait_signal not implemented");
+ caml_invalid_argument("Thread.wait_signal not implemented");
return Val_int(0); /* not reached */
}
Unix.file_descr list -> Unix.file_descr list ->
Unix.file_descr list -> float ->
Unix.file_descr list * Unix.file_descr list * Unix.file_descr list
-(** Suspend the execution of the calling thead until input/output
+(** Suspend the execution of the calling thread until input/output
becomes possible on the given Unix file descriptors.
The arguments and results have the same meaning as for
[Unix.select].
(** {6 Pipes and redirections} *)
-val pipe : unit -> Unix.file_descr * Unix.file_descr
+val pipe : ?cloexec:bool -> unit -> Unix.file_descr * Unix.file_descr
val open_process_in: string -> in_channel
val open_process_out: string -> out_channel
val open_process: string -> in_channel * out_channel
(** {6 Sockets} *)
-val socket : Unix.socket_domain ->
- Unix.socket_type -> int -> Unix.file_descr
-val accept : Unix.file_descr -> Unix.file_descr * Unix.sockaddr
+val socket :
+ ?cloexec:bool -> Unix.socket_domain -> Unix.socket_type -> int ->
+ Unix.file_descr
+val accept :
+ ?cloexec:bool -> Unix.file_descr -> Unix.file_descr * Unix.sockaddr
val connect : Unix.file_descr -> Unix.sockaddr -> unit
val recv : Unix.file_descr -> bytes ->
int -> int -> Unix.msg_flag list -> int
scheduler.o: scheduler.c ../../byterun/caml/alloc.h \
- ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
- ../../byterun/caml/config.h ../../byterun/caml/../../config/m.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.h ../../byterun/caml/exec.h \
../../byterun/caml/callback.h ../../byterun/caml/fail.h \
INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR)
+CMIFILES=thread.cmi mutex.cmi condition.cmi event.cmi threadUnix.cmi
+
install:
if test -f dllvmthreads.so; then \
cp dllvmthreads.so $(INSTALL_STUBLIBDIR)/.; \
mkdir -p $(INSTALL_LIBDIR)/vmthreads
cp libvmthreads.a $(INSTALL_LIBDIR)/vmthreads/libvmthreads.a
cd $(INSTALL_LIBDIR)/vmthreads; $(RANLIB) libvmthreads.a
- cp thread.cmi mutex.cmi condition.cmi event.cmi threadUnix.cmi \
+ cp $(CMIFILES) $(CMIFILES:.cmi=.mli) $(CMIFILES:.cmi=.cmti) \
threads.cma stdlib.cma unix.cma $(INSTALL_LIBDIR)/vmthreads
- cp thread.mli mutex.mli condition.mli event.mli threadUnix.mli \
- $(INSTALL_LIBDIR)/vmthreads
installopt:
Condition.wait c m
done;
(* Modify D *)
- if (* the predicate P over D is now satified *) then Condition.signal c;
+ if (* the predicate P over D is now satisfied *) then Condition.signal c;
Mutex.unlock m
]}
*)
| "false" -> false
| _ -> invalid_arg "bool_of_string"
+let bool_of_string_opt = function
+ | "true" -> Some true
+ | "false" -> Some false
+ | _ -> None
+
let string_of_int n =
format_int "%d" n
external int_of_string : string -> int = "caml_int_of_string"
+
+let int_of_string_opt s =
+ (* TODO: provide this directly as a non-raising primitive. *)
+ try Some (int_of_string s)
+ with Failure _ -> None
+
external string_get : string -> int -> char = "%string_safe_get"
let valid_float_lexem s =
external float_of_string : string -> float = "caml_float_of_string"
+let float_of_string_opt s =
+ (* TODO: provide this directly as a non-raising primitive. *)
+ try Some (float_of_string s)
+ with Failure _ -> None
+
(* List operations -- more in module List *)
let rec ( @ ) l1 l2 =
let read_line () = flush stdout; input_line stdin
let read_int () = int_of_string(read_line())
+let read_int_opt () = int_of_string_opt(read_line())
let read_float () = float_of_string(read_line())
+let read_float_opt () = float_of_string_opt(read_line())
(* Operations on large files *)
/* Identifier for next thread creation */
static value next_ident = Val_int(0);
-#define Assign(dst,src) modify((value *)&(dst), (value)(src))
+#define Assign(dst,src) caml_modify((value *)&(dst), (value)(src))
/* Scan the stacks of the other threads */
/* Don't scan curr_thread->sp, this has already been done.
Don't scan local roots either, for the same reason. */
for (th = start->next; th != start; th = th->next) {
- do_local_roots(action, th->sp, th->stack_high, NULL);
+ caml_do_local_roots(action, th->sp, th->stack_high, NULL);
}
/* Hook */
if (prev_scan_roots_hook != NULL) (*prev_scan_roots_hook)(action);
if (curr_thread != NULL) return Val_unit;
/* Create a descriptor for the current thread */
curr_thread =
- (caml_thread_t) alloc_shr(sizeof(struct caml_thread_struct)
+ (caml_thread_t) caml_alloc_shr(sizeof(struct caml_thread_struct)
/ sizeof(value), 0);
curr_thread->ident = next_ident;
next_ident = Val_int(Int_val(next_ident) + 1);
curr_thread->next = curr_thread;
curr_thread->prev = curr_thread;
- curr_thread->stack_low = stack_low;
- curr_thread->stack_high = stack_high;
- curr_thread->stack_threshold = stack_threshold;
- curr_thread->sp = extern_sp;
- curr_thread->trapsp = trapsp;
- curr_thread->backtrace_pos = Val_int(backtrace_pos);
- curr_thread->backtrace_buffer = backtrace_buffer;
- caml_initialize (&curr_thread->backtrace_last_exn, backtrace_last_exn);
+ curr_thread->stack_low = caml_stack_low;
+ curr_thread->stack_high = caml_stack_high;
+ curr_thread->stack_threshold = caml_stack_threshold;
+ curr_thread->sp = caml_extern_sp;
+ curr_thread->trapsp = caml_trapsp;
+ curr_thread->backtrace_pos = Val_int(caml_backtrace_pos);
+ curr_thread->backtrace_buffer = caml_backtrace_buffer;
+ caml_initialize (&curr_thread->backtrace_last_exn, caml_backtrace_last_exn);
curr_thread->status = RUNNABLE;
curr_thread->fd = Val_int(0);
curr_thread->readfds = NO_FDS;
curr_thread->waitpid = NO_WAITPID;
curr_thread->retval = Val_unit;
/* Initialize GC */
- prev_scan_roots_hook = scan_roots_hook;
- scan_roots_hook = thread_scan_roots;
+ prev_scan_roots_hook = caml_scan_roots_hook;
+ caml_scan_roots_hook = thread_scan_roots;
/* Set standard file descriptors to non-blocking mode */
stdin_initial_status = fcntl(0, F_GETFL);
stdout_initial_status = fcntl(1, F_GETFL);
caml_thread_t th;
/* Allocate the thread and its stack */
Begin_root(clos);
- th = (caml_thread_t) alloc_shr(sizeof(struct caml_thread_struct)
+ th = (caml_thread_t) caml_alloc_shr(sizeof(struct caml_thread_struct)
/ sizeof(value), 0);
End_roots();
th->ident = next_ident;
int need_select, need_wait;
/* Don't allow preemption during a callback */
- if (callback_depth > 1) return curr_thread->retval;
+ if (caml_callback_depth > 1) return curr_thread->retval;
/* Save the status of the current thread */
- curr_thread->stack_low = stack_low;
- curr_thread->stack_high = stack_high;
- curr_thread->stack_threshold = stack_threshold;
- curr_thread->sp = extern_sp;
- curr_thread->trapsp = trapsp;
- curr_thread->backtrace_pos = Val_int(backtrace_pos);
- curr_thread->backtrace_buffer = backtrace_buffer;
- caml_modify (&curr_thread->backtrace_last_exn, backtrace_last_exn);
+ curr_thread->stack_low = caml_stack_low;
+ curr_thread->stack_high = caml_stack_high;
+ curr_thread->stack_threshold = caml_stack_threshold;
+ curr_thread->sp = caml_extern_sp;
+ curr_thread->trapsp = caml_trapsp;
+ curr_thread->backtrace_pos = Val_int(caml_backtrace_pos);
+ curr_thread->backtrace_buffer = caml_backtrace_buffer;
+ caml_modify (&curr_thread->backtrace_last_exn, caml_backtrace_last_exn);
try_again:
/* Find if a thread is runnable.
else {
delay_ptr = NULL;
}
- enter_blocking_section();
+ caml_enter_blocking_section();
retcode = select(FD_SETSIZE, &readfds, &writefds, &exceptfds, delay_ptr);
- leave_blocking_section();
+ caml_leave_blocking_section();
if (retcode == -1)
switch (errno) {
case EINTR:
retcode = FD_SETSIZE;
break;
default:
- sys_error(NO_ARG);
+ caml_sys_error(NO_ARG);
}
if (retcode > 0) {
/* Some descriptors are ready.
w = inter_fdlist_set(th->writefds, &writefds, &retcode);
e = inter_fdlist_set(th->exceptfds, &exceptfds, &retcode);
if (r != NO_FDS || w != NO_FDS || e != NO_FDS) {
- value retval = alloc_small(3, TAG_RESUMED_SELECT);
+ value retval = caml_alloc_small(3, TAG_RESUMED_SELECT);
Field(retval, 0) = r;
Field(retval, 1) = w;
Field(retval, 2) = e;
}
/* If we haven't something to run at that point, we're in big trouble. */
- if (run_thread == NULL) invalid_argument("Thread: deadlock");
+ if (run_thread == NULL) caml_invalid_argument("Thread: deadlock");
/* Free everything the thread was waiting on */
Assign(run_thread->readfds, NO_FDS);
/* Activate the thread */
curr_thread = run_thread;
- stack_low = curr_thread->stack_low;
- stack_high = curr_thread->stack_high;
- stack_threshold = curr_thread->stack_threshold;
- extern_sp = curr_thread->sp;
- trapsp = curr_thread->trapsp;
- backtrace_pos = Int_val(curr_thread->backtrace_pos);
- backtrace_buffer = curr_thread->backtrace_buffer;
- backtrace_last_exn = curr_thread->backtrace_last_exn;
+ caml_stack_low = curr_thread->stack_low;
+ caml_stack_high = curr_thread->stack_high;
+ caml_stack_threshold = curr_thread->stack_threshold;
+ caml_extern_sp = curr_thread->sp;
+ caml_trapsp = curr_thread->trapsp;
+ caml_backtrace_pos = Int_val(curr_thread->backtrace_pos);
+ caml_backtrace_buffer = curr_thread->backtrace_buffer;
+ caml_backtrace_last_exn = curr_thread->backtrace_last_exn;
return curr_thread->retval;
}
static void check_callback(void)
{
- if (callback_depth > 1)
+ if (caml_callback_depth > 1)
caml_fatal_error("Thread: deadlock during callback");
}
Assert(curr_thread != NULL);
/* Pop accu from event frame, making it look like a C_CALL frame
followed by a RETURN frame */
- accu = *extern_sp++;
+ accu = *caml_extern_sp++;
/* Reschedule */
Assign(curr_thread->retval, accu);
accu = schedule_thread();
/* Push accu below C_CALL frame so that it looks like an event frame */
- *--extern_sp = accu;
+ *--caml_extern_sp = accu;
}
/* Request a re-scheduling as soon as possible */
value thread_request_reschedule(value unit) /* ML */
{
- async_action_hook = thread_reschedule;
- something_to_do = 1;
+ caml_async_action_hook = thread_reschedule;
+ caml_something_to_do = 1;
return Val_unit;
}
if (curr_thread == NULL) return RESUMED_WAKEUP;
/* As a special case, if we're in a callback, don't fail but block
the whole process till I/O is possible */
- if (callback_depth > 1) {
+ if (caml_callback_depth > 1) {
fd_set fds;
FD_ZERO(&fds);
FD_SET(Int_val(fd), &fds);
check_callback();
curr_thread->fd = Field(arg, 0);
date = timeofday() + Double_val(Field(arg, 1));
- Assign(curr_thread->delay, copy_double(date));
+ Assign(curr_thread->delay, caml_copy_double(date));
curr_thread->status = kind | BLOCKED_DELAY;
return schedule_thread();
}
date = Double_val(Field(arg, 3));
if (date >= 0.0) {
date += timeofday();
- Assign(curr_thread->delay, copy_double(date));
+ Assign(curr_thread->delay, caml_copy_double(date));
curr_thread->status = BLOCKED_SELECT | BLOCKED_DELAY;
} else {
curr_thread->status = BLOCKED_SELECT;
Assert(curr_thread != NULL);
check_callback();
curr_thread->status = BLOCKED_DELAY;
- Assign(curr_thread->delay, copy_double(date));
+ Assign(curr_thread->delay, caml_copy_double(date));
return schedule_thread();
}
Assign(th->retval, RESUMED_WAKEUP);
break;
case KILLED:
- failwith("Thread.wakeup: killed thread");
+ caml_failwith("Thread.wakeup: killed thread");
default:
- failwith("Thread.wakeup: thread not suspended");
+ caml_failwith("Thread.wakeup: thread not suspended");
}
return Val_unit;
}
{
value retval = Val_unit;
caml_thread_t th = (caml_thread_t) thread;
- if (th->status == KILLED) failwith("Thread.kill: killed thread");
+ if (th->status == KILLED) caml_failwith("Thread.kill: killed thread");
/* Don't paint ourselves in a corner */
- if (th == th->next) failwith("Thread.kill: cannot kill the last thread");
+ if (th == th->next) caml_failwith("Thread.kill: cannot kill the last thread");
/* This thread is no longer waiting on anything */
th->status = KILLED;
/* If this is the current thread, activate another one */
Assign(th->prev->next, th->next);
Assign(th->next->prev, th->prev);
/* Free its resources */
- stat_free((char *) th->stack_low);
+ caml_stat_free((char *) th->stack_low);
th->stack_low = NULL;
th->stack_high = NULL;
th->stack_threshold = NULL;
value thread_uncaught_exception(value exn) /* ML */
{
- char * msg = format_caml_exception(exn);
+ char * msg = caml_format_exception(exn);
fprintf(stderr, "Thread %d killed on uncaught exception %s\n",
Int_val(curr_thread->ident), msg);
free(msg);
- if (backtrace_active) print_exception_backtrace();
+ if (caml_backtrace_active) caml_print_exception_backtrace();
fflush(stderr);
return Val_unit;
}
for (res = NO_FDS; fdl != NO_FDS; fdl = Field(fdl, 1)) {
int fd = Int_val(Field(fdl, 0));
if (FD_ISSET(fd, set)) {
- cons = alloc_small(2, 0);
+ cons = caml_alloc_small(2, 0);
Field(cons, 0) = Val_int(fd);
Field(cons, 1) = res;
res = cons;
value st, res;
if (WIFEXITED(status)) {
- st = alloc_small(1, TAG_WEXITED);
+ st = caml_alloc_small(1, TAG_WEXITED);
Field(st, 0) = Val_int(WEXITSTATUS(status));
}
else if (WIFSTOPPED(status)) {
- st = alloc_small(1, TAG_WSTOPPED);
+ st = caml_alloc_small(1, TAG_WSTOPPED);
Field(st, 0) = Val_int(WSTOPSIG(status));
}
else {
- st = alloc_small(1, TAG_WSIGNALED);
+ st = caml_alloc_small(1, TAG_WSIGNALED);
Field(st, 0) = Val_int(WTERMSIG(status));
}
Begin_root(st);
- res = alloc_small(2, TAG_RESUMED_WAIT);
+ res = caml_alloc_small(2, TAG_RESUMED_WAIT);
Field(res, 0) = Val_int(pid);
Field(res, 1) = st;
End_roots();
Unix.file_descr list -> Unix.file_descr list -> Unix.file_descr list ->
float ->
Unix.file_descr list * Unix.file_descr list * Unix.file_descr list
-(** Suspend the execution of the calling thead until input/output
+(** Suspend the execution of the calling thread until input/output
becomes possible on the given Unix file descriptors.
The arguments and results have the same meaning as for
{!Unix.select}. *)
(the timer interrupt that transfers control from thread to thread),
causing the current thread to run uninterrupted until
[critical_section] is reset to [false] or the current thread
- explicitely relinquishes control using [sleep], [delay],
+ explicitly relinquishes control using [sleep], [delay],
[wait_inchan] or [wait_descr]. *)
val sleep : unit -> unit
(** {6 Pipes and redirections} *)
-val pipe : unit -> Unix.file_descr * Unix.file_descr
+val pipe : ?cloexec:bool -> unit -> Unix.file_descr * Unix.file_descr
val open_process_in : string -> in_channel
val open_process_out : string -> out_channel
val open_process : string -> in_channel * out_channel
(** {6 Sockets} *)
-val socket : Unix.socket_domain -> Unix.socket_type -> int -> Unix.file_descr
+val socket :
+ ?cloexec:bool -> Unix.socket_domain -> Unix.socket_type -> int ->
+ Unix.file_descr
val socketpair :
- Unix.socket_domain -> Unix.socket_type -> int ->
+ ?cloexec:bool -> Unix.socket_domain -> Unix.socket_type -> int ->
Unix.file_descr * Unix.file_descr
-val accept : Unix.file_descr -> Unix.file_descr * Unix.sockaddr
+val accept :
+ ?cloexec:bool -> Unix.file_descr -> Unix.file_descr * Unix.sockaddr
val connect : Unix.file_descr -> Unix.sockaddr -> unit
val recv :
Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> int
| O_RSYNC
| O_SHARE_DELETE
| O_CLOEXEC
+ | O_KEEPEXEC
type file_perm = int
external umask : int -> int = "unix_umask"
external access : string -> access_permission list -> unit = "unix_access"
-external dup : file_descr -> file_descr = "unix_dup"
-external dup2 : file_descr -> file_descr -> unit = "unix_dup2"
+external dup : ?cloexec: bool -> file_descr -> file_descr = "unix_dup"
+external dup2 :
+ ?cloexec: bool -> file_descr -> file_descr -> unit = "unix_dup2"
external set_nonblock : file_descr -> unit = "unix_set_nonblock"
external clear_nonblock : file_descr -> unit = "unix_clear_nonblock"
external set_close_on_exec : file_descr -> unit = "unix_set_close_on_exec"
external rewinddir : dir_handle -> unit = "unix_rewinddir"
external closedir : dir_handle -> unit = "unix_closedir"
-external _pipe : unit -> file_descr * file_descr = "unix_pipe"
+external _pipe :
+ ?cloexec: bool -> unit -> file_descr * file_descr = "unix_pipe"
-let pipe() =
- let (out_fd, in_fd as fd_pair) = _pipe() in
+let pipe ?cloexec () =
+ let (out_fd, in_fd as fd_pair) = _pipe ?cloexec () in
set_nonblock in_fd;
set_nonblock out_fd;
fd_pair
| MSG_DONTROUTE
| MSG_PEEK
-external _socket : socket_domain -> socket_type -> int -> file_descr
- = "unix_socket"
+external _socket :
+ ?cloexec: bool -> socket_domain -> socket_type -> int -> file_descr
+ = "unix_socket"
external _socketpair :
- socket_domain -> socket_type -> int -> file_descr * file_descr
- = "unix_socketpair"
+ ?cloexec: bool -> socket_domain -> socket_type -> int ->
+ file_descr * file_descr
+ = "unix_socketpair"
-let socket dom typ proto =
- let s = _socket dom typ proto in
+let socket ?cloexec dom typ proto =
+ let s = _socket ?cloexec dom typ proto in
set_nonblock s;
s
-let socketpair dom typ proto =
- let (s1, s2 as spair) = _socketpair dom typ proto in
+let socketpair ?cloexec dom typ proto =
+ let (s1, s2 as spair) = _socketpair ?cloexec dom typ proto in
set_nonblock s1; set_nonblock s2;
spair
-external _accept : file_descr -> file_descr * sockaddr = "unix_accept"
+external _accept :
+ ?cloexec: bool -> file_descr -> file_descr * sockaddr = "unix_accept"
-let rec accept req =
+let rec accept ?cloexec req =
wait_read req;
try
- let (s, caller as result) = _accept req in
+ let (s, caller as result) = _accept ?cloexec req in
set_nonblock s;
result
with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> accept req
(* High-level process management (system, popen) *)
+let rec waitpid_non_intr pid =
+ try waitpid [] pid
+ with Unix_error (EINTR, _, _) -> waitpid_non_intr pid
+
let system cmd =
match fork() with
0 -> begin try
with _ ->
exit 127
end
- | id -> snd(waitpid [] id)
-
-let rec safe_dup fd =
- let new_fd = dup fd in
- if new_fd >= 3 then
- new_fd
- else begin
- let res = safe_dup fd in
- close new_fd;
+ | id -> snd(waitpid_non_intr id)
+
+(* Make sure [fd] is not one of the standard descriptors 0, 1, 2,
+ by duplicating it if needed. *)
+
+let rec file_descr_not_standard fd =
+ if fd >= 3 then fd else begin
+ let res = file_descr_not_standard (dup fd) in
+ close fd;
res
end
-let safe_close fd =
- try close fd with Unix_error(_,_,_) -> ()
-
let perform_redirections new_stdin new_stdout new_stderr =
- let newnewstdin = safe_dup new_stdin in
- let newnewstdout = safe_dup new_stdout in
- let newnewstderr = safe_dup new_stderr in
- safe_close new_stdin;
- safe_close new_stdout;
- safe_close new_stderr;
- dup2 newnewstdin stdin; close newnewstdin;
- dup2 newnewstdout stdout; close newnewstdout;
- dup2 newnewstderr stderr; close newnewstderr
+ let new_stdin = file_descr_not_standard new_stdin in
+ let new_stdout = file_descr_not_standard new_stdout in
+ let new_stderr = file_descr_not_standard new_stderr in
+ dup2 ~cloexec:false new_stdin stdin; close new_stdin;
+ dup2 ~cloexec:false new_stdout stdout; close new_stdout;
+ dup2 ~cloexec:false new_stderr stderr; close new_stderr
let create_process cmd args new_stdin new_stdout new_stderr =
match fork() with
let popen_processes = (Hashtbl.create 7 : (popen_process, int) Hashtbl.t)
-let open_proc cmd proc input output toclose =
+let open_proc cmd envopt proc input output error =
match fork() with
- 0 -> if input <> stdin then begin dup2 input stdin; close input end;
- if output <> stdout then begin dup2 output stdout; close output end;
- List.iter close toclose;
- begin try execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]
- with _ -> exit 127
+ 0 -> begin try
+ perform_redirections input output error;
+ let shell = "/bin/sh" in
+ let argv = [| shell; "-c"; cmd |] in
+ match envopt with
+ | Some env -> execve shell argv env
+ | None -> execv shell argv
+ with _ ->
+ exit 127
end
| id -> Hashtbl.add popen_processes proc id
let open_process_in cmd =
- let (in_read, in_write) = pipe() in
+ let (in_read, in_write) = pipe ~cloexec:true () in
let inchan = in_channel_of_descr in_read in
- open_proc cmd (Process_in inchan) stdin in_write [in_read];
- close in_write;
- inchan
+ try
+ open_proc cmd None (Process_in inchan) stdin in_write stderr;
+ close in_write;
+ inchan
+ with e ->
+ close_in inchan;
+ close in_write;
+ raise e
let open_process_out cmd =
- let (out_read, out_write) = pipe() in
+ let (out_read, out_write) = pipe ~cloexec:true () in
let outchan = out_channel_of_descr out_write in
- open_proc cmd (Process_out outchan) out_read stdout [out_write];
- close out_read;
- outchan
+ try
+ open_proc cmd None (Process_out outchan) out_read stdout stderr;
+ close out_read;
+ outchan
+ with e ->
+ close_out outchan;
+ close out_read;
+ raise e
let open_process cmd =
- let (in_read, in_write) = pipe() in
- let (out_read, out_write) = pipe() in
+ let (in_read, in_write) = pipe ~cloexec:true () in
let inchan = in_channel_of_descr in_read in
- let outchan = out_channel_of_descr out_write in
- open_proc cmd (Process(inchan, outchan)) out_read in_write
- [in_read; out_write];
- close out_read;
- close in_write;
- (inchan, outchan)
-
-let open_proc_full cmd env proc input output error toclose =
- match fork() with
- 0 -> dup2 input stdin; close input;
- dup2 output stdout; close output;
- dup2 error stderr; close error;
- List.iter close toclose;
- begin try execve "/bin/sh" [| "/bin/sh"; "-c"; cmd |] env
- with _ -> exit 127
- end
- | id -> Hashtbl.add popen_processes proc id
+ try
+ let (out_read, out_write) = pipe ~cloexec:true () in
+ let outchan = out_channel_of_descr out_write in
+ try
+ open_proc cmd None (Process(inchan, outchan)) out_read in_write stderr;
+ close out_read;
+ close in_write;
+ (inchan, outchan)
+ with e ->
+ close_out outchan;
+ close out_read;
+ raise e
+ with e ->
+ close_in inchan;
+ close in_write;
+ raise e
let open_process_full cmd env =
- let (in_read, in_write) = pipe() in
- let (out_read, out_write) = pipe() in
- let (err_read, err_write) = pipe() in
+ let (in_read, in_write) = pipe ~cloexec:true () in
let inchan = in_channel_of_descr in_read in
- let outchan = out_channel_of_descr out_write in
- let errchan = in_channel_of_descr err_read in
- open_proc_full cmd env (Process_full(inchan, outchan, errchan))
- out_read in_write err_write [in_read; out_write; err_read];
- close out_read;
- close in_write;
- close err_write;
- (inchan, outchan, errchan)
+ try
+ let (out_read, out_write) = pipe ~cloexec:true () in
+ let outchan = out_channel_of_descr out_write in
+ try
+ let (err_read, err_write) = pipe ~cloexec:true () in
+ let errchan = in_channel_of_descr err_read in
+ try
+ open_proc cmd (Some env) (Process_full(inchan, outchan, errchan))
+ out_read in_write err_write;
+ close out_read;
+ close in_write;
+ close err_write;
+ (inchan, outchan, errchan)
+ with e ->
+ close_in errchan;
+ close err_write;
+ raise e
+ with e ->
+ close_out outchan;
+ close out_read;
+ raise e
+ with e ->
+ close_in inchan;
+ close in_write;
+ raise e
+
+let find_proc_id fun_name proc =
+ try
+ let pid = Hashtbl.find popen_processes proc in
+ Hashtbl.remove popen_processes proc;
+ pid
+ with Not_found ->
+ raise(Unix_error(EBADF, fun_name, ""))
+
+let close_process_in inchan =
+ let pid = find_proc_id "close_process_in" (Process_in inchan) in
+ close_in inchan;
+ snd(waitpid_non_intr pid)
+
+let close_process_out outchan =
+ let pid = find_proc_id "close_process_out" (Process_out outchan) in
+ (* The application may have closed [outchan] already to signal
+ end-of-input to the process. *)
+ begin try close_out outchan with Sys_error _ -> () end;
+ snd(waitpid_non_intr pid)
+
+let close_process (inchan, outchan) =
+ let pid = find_proc_id "close_process" (Process(inchan, outchan)) in
+ close_in inchan;
+ begin try close_out outchan with Sys_error _ -> () end;
+ snd(waitpid_non_intr pid)
+
+let close_process_full (inchan, outchan, errchan) =
+ let pid =
+ find_proc_id "close_process_full"
+ (Process_full(inchan, outchan, errchan)) in
+ close_in inchan;
+ begin try close_out outchan with Sys_error _ -> () end;
+ close_in errchan;
+ snd(waitpid_non_intr pid)
let find_proc_id fun_name proc =
try
let open_connection sockaddr =
let sock =
- socket (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
+ socket ~cloexec:true (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
try
connect sock sockaddr;
(in_channel_of_descr sock, out_channel_of_descr sock)
let shutdown_connection inchan =
shutdown (descr_of_in_channel inchan) SHUTDOWN_SEND
+let rec accept_non_intr s =
+ try accept ~cloexec:true s
+ with Unix_error (EINTR, _, _) -> accept_non_intr s
+
let establish_server server_fun sockaddr =
let sock =
- socket (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
+ socket ~cloexec:true (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
setsockopt sock SO_REUSEADDR true;
bind sock sockaddr;
listen sock 5;
while true do
- let (s, caller) = accept 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
0 -> if fork() <> 0 then exit 0; (* The son exits, the grandson works *)
+ close sock;
let inchan = in_channel_of_descr s in
let outchan = out_channel_of_descr s in
server_fun inchan outchan;
- close_out outchan;
- (* The file descriptor was already closed by close_out.
- close_in inchan;
- *)
+ (* Do not close inchan nor outchan, as the server_fun could
+ have done it already, and we are about to exit anyway
+ (PR#3794) *)
exit 0
- | id -> close s; ignore(waitpid [] id) (* Reclaim the son *)
+ | id -> close s; ignore(waitpid_non_intr id) (* Reclaim the son *)
done
../../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 unixsupport.h
+ ../../byterun/caml/memory.h ../../byterun/caml/osdeps.h unixsupport.h
exit.o: exit.c ../../byterun/caml/mlvalues.h \
../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
../../byterun/caml/../../config/m.h \
EXTRACAMLFLAGS=-nolabels
+# dllunix.so particularly requires libm for modf symbols
+LDOPTS=$(NATIVECCLIBS)
+
COBJS=accept.o access.o addrofstr.o alarm.o bind.o chdir.o chmod.o \
chown.o chroot.o close.o closedir.o connect.o cst2constr.o cstringv.o \
dup.o dup2.o envir.o errmsg.o execv.o execve.o execvp.o exit.o \
/* */
/**************************************************************************/
+#define _GNU_SOURCE
#include <caml/mlvalues.h>
#include <caml/alloc.h>
#include <caml/fail.h>
#include "socketaddr.h"
-CAMLprim value unix_accept(value sock)
+CAMLprim value unix_accept(value cloexec, value sock)
{
int retcode;
value res;
value a;
union sock_addr_union addr;
socklen_param_type addr_len;
+ int clo = unix_cloexec_p(cloexec);
addr_len = sizeof(addr);
- enter_blocking_section();
+ caml_enter_blocking_section();
+#if defined(HAS_ACCEPT4) && defined(SOCK_CLOEXEC)
+ retcode = accept4(Int_val(sock), &addr.s_gen, &addr_len,
+ clo ? SOCK_CLOEXEC : 0);
+#else
retcode = accept(Int_val(sock), &addr.s_gen, &addr_len);
- leave_blocking_section();
+#endif
+ caml_leave_blocking_section();
if (retcode == -1) uerror("accept", Nothing);
+#if !(defined(HAS_ACCEPT4) && defined(SOCK_CLOEXEC))
+ if (clo) unix_set_cloexec(retcode, "accept", Nothing);
+#endif
a = alloc_sockaddr(&addr, addr_len, retcode);
Begin_root (a);
- res = alloc_small(2, 0);
+ res = caml_alloc_small(2, 0);
Field(res, 0) = Val_int(retcode);
Field(res, 1) = a;
End_roots();
#else
-CAMLprim value unix_accept(value sock)
-{ invalid_argument("accept not implemented"); }
+CAMLprim value unix_accept(value cloexec, value sock)
+{ caml_invalid_argument("accept not implemented"); }
#endif
#else
# ifndef _WIN32
# include <sys/file.h>
-# ifndef R_OK
+# endif
+# ifndef R_OK
# define R_OK 4/* test for read permission */
# define W_OK 2/* test for write permission */
# define X_OK 1/* test for execute (search) permission */
# define F_OK 0/* test for presence of file */
-# endif
-# else
-# define R_OK 4/* test for read permission */
-# define W_OK 2/* test for write permission */
-# define X_OK 4/* test for execute permission - not implemented in Win32 */
-# define F_OK 0/* test for presence of file */
# endif
#endif
static int access_permission_table[] = {
- R_OK, W_OK, X_OK, F_OK
+ R_OK,
+ W_OK,
+#ifdef _WIN32
+ /* Since there is no concept of execute permission on Windows,
+ we fall b+ack to the read permission */
+ R_OK,
+#else
+ X_OK,
+#endif
+ F_OK
};
CAMLprim value unix_access(value path, value perms)
int ret, cv_flags;
caml_unix_check_path(path, "access");
- cv_flags = convert_flag_list(perms, access_permission_table);
+ cv_flags = caml_convert_flag_list(perms, access_permission_table);
p = caml_strdup(String_val(path));
caml_enter_blocking_section();
ret = access(p, cv_flags);
CAMLprim value unix_inet_addr_of_string(value s)
{
- if (! caml_string_is_c_safe(s)) failwith("inet_addr_of_string");
+ if (! caml_string_is_c_safe(s)) caml_failwith("inet_addr_of_string");
#if defined(HAS_IPV6)
#ifdef _WIN32
{
hints.ai_family = AF_UNSPEC;
hints.ai_flags = AI_NUMERICHOST;
retcode = getaddrinfo(String_val(s), NULL, &hints, &res);
- if (retcode != 0) failwith("inet_addr_of_string");
+ if (retcode != 0) caml_failwith("inet_addr_of_string");
switch (res->ai_addr->sa_family) {
case AF_INET:
{
default:
{
freeaddrinfo(res);
- failwith("inet_addr_of_string");
+ caml_failwith("inet_addr_of_string");
}
}
freeaddrinfo(res);
else if (inet_pton(AF_INET6, String_val(s), &address6) > 0)
return alloc_inet6_addr(&address6);
else
- failwith("inet_addr_of_string");
+ caml_failwith("inet_addr_of_string");
}
#endif
#elif defined(HAS_INET_ATON)
{
struct in_addr address;
if (inet_aton(String_val(s), &address) == 0)
- failwith("inet_addr_of_string");
+ caml_failwith("inet_addr_of_string");
return alloc_inet_addr(&address);
}
#else
{
struct in_addr address;
address.s_addr = inet_addr(String_val(s));
- if (address.s_addr == (uint32_t) -1) failwith("inet_addr_of_string");
+ if (address.s_addr == (uint32_t) -1) caml_failwith("inet_addr_of_string");
return alloc_inet_addr(&address);
}
#endif
#else
CAMLprim value unix_inet_addr_of_string(value s)
-{ invalid_argument("inet_addr_of_string not implemented"); }
+{ caml_invalid_argument("inet_addr_of_string not implemented"); }
#endif
#else
CAMLprim value unix_bind(value socket, value address)
-{ invalid_argument("bind not implemented"); }
+{ caml_invalid_argument("bind not implemented"); }
#endif
socklen_param_type addr_len;
get_sockaddr(address, &addr, &addr_len);
- enter_blocking_section();
+ caml_enter_blocking_section();
retcode = connect(Int_val(socket), &addr.s_gen, addr_len);
- leave_blocking_section();
+ caml_leave_blocking_section();
if (retcode == -1) uerror("connect", Nothing);
return Val_unit;
}
#else
CAMLprim value unix_connect(value socket, value address)
-{ invalid_argument("connect not implemented"); }
+{ caml_invalid_argument("connect not implemented"); }
#endif
/* */
/**************************************************************************/
+#define _GNU_SOURCE
#include <caml/mlvalues.h>
#include "unixsupport.h"
+#include <fcntl.h>
-CAMLprim value unix_dup(value fd)
+CAMLprim value unix_dup(value cloexec, value fd)
{
int ret;
+#ifdef F_DUPFD_CLOEXEC
+ ret = fcntl(Int_val(fd),
+ (unix_cloexec_p(cloexec) ? F_DUPFD_CLOEXEC : F_DUPFD),
+ 0);
+#else
ret = dup(Int_val(fd));
+#endif
if (ret == -1) uerror("dup", Nothing);
+#ifndef F_DUPFD_CLOEXEC
+ if (unix_cloexec_p(cloexec)) unix_set_cloexec(ret, "dup", Nothing);
+#endif
return Val_int(ret);
}
/* */
/**************************************************************************/
+#define _GNU_SOURCE
#include <caml/mlvalues.h>
#include "unixsupport.h"
+#include <fcntl.h>
-#ifdef HAS_DUP2
-
-CAMLprim value unix_dup2(value fd1, value fd2)
+CAMLprim value unix_dup2(value cloexec, value fd1, value fd2)
{
- if (dup2(Int_val(fd1), Int_val(fd2)) == -1) uerror("dup2", Nothing);
- return Val_unit;
-}
-
+ if (Int_val(fd2) == Int_val(fd1)) {
+ /* In this case, dup3 fails and dup2 does nothing. */
+ /* Just apply the cloexec flag to fd2, if it is given. */
+ if (Is_block(cloexec)) {
+ if (Bool_val(Field(cloexec, 0)))
+ unix_set_cloexec(Int_val(fd2), "dup2", Nothing);
+ else
+ unix_clear_cloexec(Int_val(fd2), "dup2", Nothing);
+ }
+ } else {
+#ifdef HAS_DUP3
+ if (dup3(Int_val(fd1), Int_val(fd2),
+ unix_cloexec_p(cloexec) ? O_CLOEXEC : 0) == -1)
+ uerror("dup2", Nothing);
#else
-
-static int do_dup2(int fd1, int fd2)
-{
- int fd;
- int res;
-
- fd = dup(fd1);
- if (fd == -1) return -1;
- if (fd == fd2) return 0;
- res = do_dup2(fd1, fd2);
- close(fd);
- return res;
-}
-
-CAMLprim value unix_dup2(value fd1, value fd2)
-{
- close(Int_val(fd2));
- if (do_dup2(Int_val(fd1), Int_val(fd2)) == -1) uerror("dup2", Nothing);
+ if (dup2(Int_val(fd1), Int_val(fd2)) == -1) uerror("dup2", Nothing);
+ if (unix_cloexec_p(cloexec))
+ unix_set_cloexec(Int_val(fd2), "dup2", Nothing);
+#endif
+ }
return Val_unit;
}
-
-#endif
CAMLprim value unix_environment(value unit)
{
if (environ != NULL) {
- return copy_string_array((const char**)environ);
+ return caml_copy_string_array((const char**)environ);
} else {
return Atom(0);
}
{
int errnum;
errnum = Is_block(err) ? Int_val(Field(err, 0)) : error_table[Int_val(err)];
- return copy_string(strerror(errnum));
+ return caml_copy_string(strerror(errnum));
}
caml_unix_check_path(path, "execv");
argv = cstringvect(args, "execv");
(void) execv(String_val(path), argv);
- stat_free((char *) argv);
+ caml_stat_free((char *) argv);
uerror("execv", path);
return Val_unit; /* never reached, but suppress warnings */
/* from smart compilers */
argv = cstringvect(args, "execve");
envp = cstringvect(env, "execve");
(void) execve(String_val(path), argv, envp);
- stat_free((char *) argv);
- stat_free((char *) envp);
+ caml_stat_free((char *) argv);
+ caml_stat_free((char *) envp);
uerror("execve", path);
return Val_unit; /* never reached, but suppress warnings */
/* from smart compilers */
#include <caml/mlvalues.h>
#include <caml/memory.h>
+#define CAML_INTERNALS
+#include <caml/osdeps.h>
#include "unixsupport.h"
#ifndef _WIN32
caml_unix_check_path(path, "execvp");
argv = cstringvect(args, "execvp");
(void) execvp(String_val(path), argv);
- stat_free((char *) argv);
+ caml_stat_free((char *) argv);
uerror("execvp", path);
return Val_unit; /* never reached, but suppress warnings */
- /* from smart compilers */
+ /* from smart compilers */
}
CAMLprim value unix_execvpe(value path, value args, value env)
{
+ char * exefile;
char ** argv;
- char ** saved_environ;
+ char ** envp;
caml_unix_check_path(path, "execvpe");
+ exefile = caml_search_exe_in_path(String_val(path));
argv = cstringvect(args, "execvpe");
- saved_environ = environ;
- environ = cstringvect(env, "execvpe");
- (void) execvp(String_val(path), argv);
- stat_free((char *) argv);
- stat_free((char *) environ);
- environ = saved_environ;
- uerror("execvp", path);
+ envp = cstringvect(env, "execvpe");
+ (void) execve(exefile, argv, envp);
+ caml_stat_free(exefile);
+ caml_stat_free((char *) argv);
+ caml_stat_free((char *) envp);
+ uerror("execvpe", path);
return Val_unit; /* never reached, but suppress warnings */
- /* from smart compilers */
+ /* from smart compilers */
}
#else
CAMLprim value unix_fchmod(value fd, value perm)
-{ invalid_argument("fchmod not implemented"); }
+{ caml_invalid_argument("fchmod not implemented"); }
#endif
#else
CAMLprim value unix_fchown(value fd, value uid, value gid)
-{ invalid_argument("fchown not implemented"); }
+{ caml_invalid_argument("fchown not implemented"); }
#endif
return Val_unit;
}
-#ifdef FD_CLOEXEC
-
CAMLprim value unix_set_close_on_exec(value fd)
{
- int retcode;
- retcode = fcntl(Int_val(fd), F_GETFD, 0);
- if (retcode == -1 ||
- fcntl(Int_val(fd), F_SETFD, retcode | FD_CLOEXEC) == -1)
- uerror("set_close_on_exec", Nothing);
+ unix_set_cloexec(Int_val(fd), "set_close_on_exec", Nothing);
return Val_unit;
}
CAMLprim value unix_clear_close_on_exec(value fd)
{
- int retcode;
- retcode = fcntl(Int_val(fd), F_GETFD, 0);
- if (retcode == -1 ||
- fcntl(Int_val(fd), F_SETFD, retcode & ~FD_CLOEXEC) == -1)
- uerror("clear_close_on_exec", Nothing);
+ unix_clear_cloexec(Int_val(fd), "set_close_on_exec", Nothing);
return Val_unit;
}
-
-#else
-
-CAMLprim value unix_set_close_on_exec(value fd)
-{ invalid_argument("set_close_on_exec not implemented"); }
-
-CAMLprim value unix_clear_close_on_exec(value fd)
-{ invalid_argument("clear_close_on_exec not implemented"); }
-
-#endif
#else
CAMLprim value unix_ftruncate(value fd, value len)
-{ invalid_argument("ftruncate not implemented"); }
+{ caml_invalid_argument("ftruncate not implemented"); }
CAMLprim value unix_ftruncate_64(value fd, value len)
-{ invalid_argument("ftruncate not implemented"); }
+{ caml_invalid_argument("ftruncate not implemented"); }
#endif
if (len > sizeof(sa)) len = sizeof(sa);
memcpy(&sa.s_gen, a->ai_addr, len);
vaddr = alloc_sockaddr(&sa, len, -1);
- vcanonname = copy_string(a->ai_canonname == NULL ? "" : a->ai_canonname);
- vres = alloc_small(5, 0);
+ vcanonname = caml_copy_string(a->ai_canonname == NULL ? "" : a->ai_canonname);
+ vres = caml_alloc_small(5, 0);
Field(vres, 0) = cst_to_constr(a->ai_family, socket_domain_table, 3, 0);
Field(vres, 1) = cst_to_constr(a->ai_socktype, socket_type_table, 4, 0);
Field(vres, 2) = Val_int(a->ai_protocol);
}
}
/* Do the call */
- enter_blocking_section();
+ caml_enter_blocking_section();
retcode = getaddrinfo(node, serv, &hints, &res);
- leave_blocking_section();
- if (node != NULL) stat_free(node);
- if (serv != NULL) stat_free(serv);
+ caml_leave_blocking_section();
+ if (node != NULL) caml_stat_free(node);
+ if (serv != NULL) caml_stat_free(serv);
/* Convert result */
vres = Val_int(0);
if (retcode == 0) {
for (r = res; r != NULL; r = r->ai_next) {
e = convert_addrinfo(r);
- v = alloc_small(2, 0);
+ v = caml_alloc_small(2, 0);
Field(v, 0) = e;
Field(v, 1) = vres;
vres = v;
#else
CAMLprim value unix_getaddrinfo(value vnode, value vserv, value vopts)
-{ invalid_argument("getaddrinfo not implemented"); }
+{ caml_invalid_argument("getaddrinfo not implemented"); }
#endif
{
char buff[PATH_MAX];
if (getcwd(buff, sizeof(buff)) == 0) uerror("getcwd", Nothing);
- return copy_string(buff);
+ return caml_copy_string(buff);
}
#else
#else
CAMLprim value unix_getcwd(value unit)
-{ invalid_argument("getcwd not implemented"); }
+{ caml_invalid_argument("getcwd not implemented"); }
#endif
#endif
value name = Val_unit, pass = Val_unit, mem = Val_unit;
Begin_roots3 (name, pass, mem);
- name = copy_string(entry->gr_name);
- pass = copy_string(entry->gr_passwd);
- mem = copy_string_array((const char**)entry->gr_mem);
- res = alloc_small(4, 0);
+ name = caml_copy_string(entry->gr_name);
+ /* on some platforms, namely Android, gr_passwd can be NULL - hence this workaround */
+ pass = caml_copy_string(entry->gr_passwd ? entry->gr_passwd : "");
+ mem = caml_copy_string_array((const char**)entry->gr_mem);
+ res = caml_alloc_small(4, 0);
Field(res,0) = name;
Field(res,1) = pass;
Field(res,2) = Val_int(entry->gr_gid);
CAMLprim value unix_getgrnam(value name)
{
struct group * entry;
- if (! caml_string_is_c_safe(name)) raise_not_found();
+ if (! caml_string_is_c_safe(name)) caml_raise_not_found();
entry = getgrnam(String_val(name));
- if (entry == NULL) raise_not_found();
+ if (entry == NULL) caml_raise_not_found();
return alloc_group_entry(entry);
}
{
struct group * entry;
entry = getgrgid(Int_val(gid));
- if (entry == NULL) raise_not_found();
+ if (entry == NULL) caml_raise_not_found();
return alloc_group_entry(entry);
}
n = getgroups(NGROUPS_MAX, gidset);
if (n == -1) uerror("getgroups", Nothing);
- res = alloc_tuple(n);
+ res = caml_alloc_tuple(n);
for (i = 0; i < n; i++)
Field(res, i) = Val_int(gidset[i]);
return res;
#else
CAMLprim value unix_getgroups(value unit)
-{ invalid_argument("getgroups not implemented"); }
+{ caml_invalid_argument("getgroups not implemented"); }
#endif
value addr_list = Val_unit, adr = Val_unit;
Begin_roots4 (name, aliases, addr_list, adr);
- name = copy_string((char *)(entry->h_name));
+ name = caml_copy_string((char *)(entry->h_name));
/* PR#4043: protect against buggy implementations of gethostbyname()
that return a NULL pointer in h_aliases */
if (entry->h_aliases)
- aliases = copy_string_array((const char**)entry->h_aliases);
+ aliases = caml_copy_string_array((const char**)entry->h_aliases);
else
aliases = Atom(0);
entry_h_length = entry->h_length;
#ifdef h_addr
- addr_list = alloc_array(alloc_one_addr, (const char**)entry->h_addr_list);
+ addr_list = caml_alloc_array(alloc_one_addr, (const char**)entry->h_addr_list);
#else
adr = alloc_one_addr(entry->h_addr);
- addr_list = alloc_small(1, 0);
+ addr_list = caml_alloc_small(1, 0);
Field(addr_list, 0) = adr;
#endif
- res = alloc_small(4, 0);
+ res = caml_alloc_small(4, 0);
Field(res, 0) = name;
Field(res, 1) = aliases;
switch (entry->h_addrtype) {
struct hostent h;
char buffer[NETDB_BUFFER_SIZE];
int h_errnop;
- enter_blocking_section();
+ caml_enter_blocking_section();
hp = gethostbyaddr_r((char *) &adr, 4, AF_INET,
&h, buffer, sizeof(buffer), &h_errnop);
- leave_blocking_section();
+ caml_leave_blocking_section();
#elif HAS_GETHOSTBYADDR_R == 8
struct hostent h;
char buffer[NETDB_BUFFER_SIZE];
int h_errnop, rc;
- enter_blocking_section();
+ caml_enter_blocking_section();
rc = gethostbyaddr_r((char *) &adr, 4, AF_INET,
&h, buffer, sizeof(buffer), &hp, &h_errnop);
- leave_blocking_section();
+ caml_leave_blocking_section();
if (rc != 0) hp = NULL;
#else
#ifdef GETHOSTBYADDR_IS_REENTRANT
- enter_blocking_section();
+ caml_enter_blocking_section();
#endif
hp = gethostbyaddr((char *) &adr, 4, AF_INET);
#ifdef GETHOSTBYADDR_IS_REENTRANT
- leave_blocking_section();
+ caml_leave_blocking_section();
#endif
#endif
- if (hp == (struct hostent *) NULL) raise_not_found();
+ if (hp == (struct hostent *) NULL) caml_raise_not_found();
return alloc_host_entry(hp);
}
int err;
#endif
- if (! caml_string_is_c_safe(name)) raise_not_found();
+ if (! caml_string_is_c_safe(name)) caml_raise_not_found();
#if HAS_GETHOSTBYNAME_R || GETHOSTBYNAME_IS_REENTRANT
hostname = caml_strdup(String_val(name));
#if HAS_GETHOSTBYNAME_R == 5
{
- enter_blocking_section();
+ caml_enter_blocking_section();
hp = gethostbyname_r(hostname, &h, buffer, sizeof(buffer), &err);
- leave_blocking_section();
+ caml_leave_blocking_section();
}
#elif HAS_GETHOSTBYNAME_R == 6
{
int rc;
- enter_blocking_section();
+ caml_enter_blocking_section();
rc = gethostbyname_r(hostname, &h, buffer, sizeof(buffer), &hp, &err);
- leave_blocking_section();
+ caml_leave_blocking_section();
if (rc != 0) hp = NULL;
}
#else
#ifdef GETHOSTBYNAME_IS_REENTRANT
- enter_blocking_section();
+ caml_enter_blocking_section();
#endif
hp = gethostbyname(hostname);
#ifdef GETHOSTBYNAME_IS_REENTRANT
- leave_blocking_section();
+ caml_leave_blocking_section();
#endif
#endif
#if HAS_GETHOSTBYNAME_R || GETHOSTBYNAME_IS_REENTRANT
- stat_free(hostname);
+ caml_stat_free(hostname);
#endif
- if (hp == (struct hostent *) NULL) raise_not_found();
+ if (hp == (struct hostent *) NULL) caml_raise_not_found();
return alloc_host_entry(hp);
}
#else
CAMLprim value unix_gethostbyaddr(value name)
-{ invalid_argument("gethostbyaddr not implemented"); }
+{ caml_invalid_argument("gethostbyaddr not implemented"); }
CAMLprim value unix_gethostbyname(value name)
-{ invalid_argument("gethostbyname not implemented"); }
+{ caml_invalid_argument("gethostbyname not implemented"); }
#endif
char name[MAXHOSTNAMELEN];
gethostname(name, MAXHOSTNAMELEN);
name[MAXHOSTNAMELEN-1] = 0;
- return copy_string(name);
+ return caml_copy_string(name);
}
#else
#else
CAMLprim value unix_gethostname(value unit)
-{ invalid_argument("gethostname not implemented"); }
+{ caml_invalid_argument("gethostname not implemented"); }
#endif
#endif
char * name;
name = getlogin();
if (name == NULL) unix_error(ENOENT, "getlogin", Nothing);
- return copy_string(name);
+ return caml_copy_string(name);
}
int opts, retcode;
get_sockaddr(vaddr, &addr, &addr_len);
- opts = convert_flag_list(vopts, getnameinfo_flag_table);
- enter_blocking_section();
+ opts = caml_convert_flag_list(vopts, getnameinfo_flag_table);
+ caml_enter_blocking_section();
retcode =
getnameinfo((const struct sockaddr *) &addr.s_gen, addr_len,
host, sizeof(host), serv, sizeof(serv), opts);
- leave_blocking_section();
- if (retcode != 0) raise_not_found(); /* TODO: detailed error reporting? */
- vhost = copy_string(host);
- vserv = copy_string(serv);
- vres = alloc_small(2, 0);
+ caml_leave_blocking_section();
+ if (retcode != 0) caml_raise_not_found(); /* TODO: detailed error reporting? */
+ vhost = caml_copy_string(host);
+ vserv = caml_copy_string(serv);
+ vres = caml_alloc_small(2, 0);
Field(vres, 0) = vhost;
Field(vres, 1) = vserv;
CAMLreturn(vres);
#else
CAMLprim value unix_getnameinfo(value vaddr, value vopts)
-{ invalid_argument("getnameinfo not implemented"); }
+{ caml_invalid_argument("getnameinfo not implemented"); }
#endif
#else
CAMLprim value unix_getpeername(value sock)
-{ invalid_argument("getpeername not implemented"); }
+{ caml_invalid_argument("getpeername not implemented"); }
#endif
value name = Val_unit, aliases = Val_unit;
Begin_roots2 (name, aliases);
- name = copy_string(entry->p_name);
- aliases = copy_string_array((const char**)entry->p_aliases);
- res = alloc_small(3, 0);
+ name = caml_copy_string(entry->p_name);
+ aliases = caml_copy_string_array((const char**)entry->p_aliases);
+ res = caml_alloc_small(3, 0);
Field(res,0) = name;
Field(res,1) = aliases;
Field(res,2) = Val_int(entry->p_proto);
CAMLprim value unix_getprotobyname(value name)
{
struct protoent * entry;
- if (! caml_string_is_c_safe(name)) raise_not_found();
+ if (! caml_string_is_c_safe(name)) caml_raise_not_found();
entry = getprotobyname(String_val(name));
- if (entry == (struct protoent *) NULL) raise_not_found();
+ if (entry == (struct protoent *) NULL) caml_raise_not_found();
return alloc_proto_entry(entry);
}
{
struct protoent * entry;
entry = getprotobynumber(Int_val(proto));
- if (entry == (struct protoent *) NULL) raise_not_found();
+ if (entry == (struct protoent *) NULL) caml_raise_not_found();
return alloc_proto_entry(entry);
}
#else
CAMLprim value unix_getprotobynumber(value proto)
-{ invalid_argument("getprotobynumber not implemented"); }
+{ caml_invalid_argument("getprotobynumber not implemented"); }
CAMLprim value unix_getprotobyname(value name)
-{ invalid_argument("getprotobyname not implemented"); }
+{ caml_invalid_argument("getprotobyname not implemented"); }
#endif
value dir = Val_unit, shell = Val_unit;
Begin_roots5 (name, passwd, gecos, dir, shell);
- name = copy_string(entry->pw_name);
- passwd = copy_string(entry->pw_passwd);
+ name = caml_copy_string(entry->pw_name);
+ passwd = caml_copy_string(entry->pw_passwd);
#if !defined(__BEOS__) && !defined(__ANDROID__)
- gecos = copy_string(entry->pw_gecos);
+ gecos = caml_copy_string(entry->pw_gecos);
#else
- gecos = copy_string("");
+ gecos = caml_copy_string("");
#endif
- dir = copy_string(entry->pw_dir);
- shell = copy_string(entry->pw_shell);
- res = alloc_small(7, 0);
+ dir = caml_copy_string(entry->pw_dir);
+ shell = caml_copy_string(entry->pw_shell);
+ res = caml_alloc_small(7, 0);
Field(res,0) = name;
Field(res,1) = passwd;
Field(res,2) = Val_int(entry->pw_uid);
CAMLprim value unix_getpwnam(value name)
{
struct passwd * entry;
- if (! caml_string_is_c_safe(name)) raise_not_found();
+ if (! caml_string_is_c_safe(name)) caml_raise_not_found();
entry = getpwnam(String_val(name));
- if (entry == (struct passwd *) NULL) raise_not_found();
+ if (entry == (struct passwd *) NULL) caml_raise_not_found();
return alloc_passwd_entry(entry);
}
{
struct passwd * entry;
entry = getpwuid(Int_val(uid));
- if (entry == (struct passwd *) NULL) raise_not_found();
+ if (entry == (struct passwd *) NULL) caml_raise_not_found();
return alloc_passwd_entry(entry);
}
value name = Val_unit, aliases = Val_unit, proto = Val_unit;
Begin_roots3 (name, aliases, proto);
- name = copy_string(entry->s_name);
- aliases = copy_string_array((const char**)entry->s_aliases);
- proto = copy_string(entry->s_proto);
- res = alloc_small(4, 0);
+ name = caml_copy_string(entry->s_name);
+ aliases = caml_copy_string_array((const char**)entry->s_aliases);
+ proto = caml_copy_string(entry->s_proto);
+ res = caml_alloc_small(4, 0);
Field(res,0) = name;
Field(res,1) = aliases;
Field(res,2) = Val_int(ntohs(entry->s_port));
{
struct servent * entry;
if (! (caml_string_is_c_safe(name) && caml_string_is_c_safe(proto)))
- raise_not_found();
+ caml_raise_not_found();
entry = getservbyname(String_val(name), String_val(proto));
- if (entry == (struct servent *) NULL) raise_not_found();
+ if (entry == (struct servent *) NULL) caml_raise_not_found();
return alloc_service_entry(entry);
}
CAMLprim value unix_getservbyport(value port, value proto)
{
struct servent * entry;
- if (! caml_string_is_c_safe(proto)) raise_not_found();
+ if (! caml_string_is_c_safe(proto)) caml_raise_not_found();
entry = getservbyport(htons(Int_val(port)), String_val(proto));
- if (entry == (struct servent *) NULL) raise_not_found();
+ if (entry == (struct servent *) NULL) caml_raise_not_found();
return alloc_service_entry(entry);
}
#else
CAMLprim value unix_getservbyport(value port, value proto)
-{ invalid_argument("getservbyport not implemented"); }
+{ caml_invalid_argument("getservbyport not implemented"); }
CAMLprim value unix_getservbyname(value name, value proto)
-{ invalid_argument("getservbyname not implemented"); }
+{ caml_invalid_argument("getservbyname not implemented"); }
#endif
#else
CAMLprim value unix_getsockname(value sock)
-{ invalid_argument("getsockname not implemented"); }
+{ caml_invalid_argument("getsockname not implemented"); }
#endif
{
struct timeval tp;
if (gettimeofday(&tp, NULL) == -1) uerror("gettimeofday", Nothing);
- return copy_double((double) tp.tv_sec + (double) tp.tv_usec / 1e6);
+ return caml_copy_double((double) tp.tv_sec + (double) tp.tv_usec / 1e6);
}
#else
CAMLprim value unix_gettimeofday(value unit)
-{ invalid_argument("gettimeofday not implemented"); }
+{ caml_invalid_argument("gettimeofday not implemented"); }
#endif
static value alloc_tm(struct tm *tm)
{
value res;
- res = alloc_small(9, 0);
+ res = caml_alloc_small(9, 0);
Field(res,0) = Val_int(tm->tm_sec);
Field(res,1) = Val_int(tm->tm_min);
Field(res,2) = Val_int(tm->tm_hour);
clock = mktime(&tm);
if (clock == (time_t) -1) unix_error(ERANGE, "mktime", Nothing);
tmval = alloc_tm(&tm);
- clkval = copy_double((double) clock);
- res = alloc_small(2, 0);
+ clkval = caml_copy_double((double) clock);
+ res = caml_alloc_small(2, 0);
Field(res, 0) = clkval;
Field(res, 1) = tmval;
End_roots ();
#else
CAMLprim value unix_mktime(value t)
-{ invalid_argument("mktime not implemented"); }
+{ caml_invalid_argument("mktime not implemented"); }
#endif
#else
CAMLprim value unix_initgroups(value user, value group)
-{ invalid_argument("initgroups not implemented"); }
+{ caml_invalid_argument("initgroups not implemented"); }
#endif
static value unix_convert_itimer(struct itimerval *tp)
{
#define Get_timeval(tv) (double) tv.tv_sec + (double) tv.tv_usec / 1e6
- value res = alloc_small(Double_wosize * 2, Double_array_tag);
+ value res = caml_alloc_small(Double_wosize * 2, Double_array_tag);
Store_double_field(res, 0, Get_timeval(tp->it_interval));
Store_double_field(res, 1, Get_timeval(tp->it_value));
return res;
#else
CAMLprim value unix_setitimer(value which, value newval)
-{ invalid_argument("setitimer not implemented"); }
+{ caml_invalid_argument("setitimer not implemented"); }
CAMLprim value unix_getitimer(value which)
-{ invalid_argument("getitimer not implemented"); }
+{ caml_invalid_argument("getitimer not implemented"); }
#endif
CAMLprim value unix_kill(value pid, value signal)
{
int sig;
- sig = convert_signal_number(Int_val(signal));
+ sig = caml_convert_signal_number(Int_val(signal));
if (kill(Int_val(pid), sig) == -1)
uerror("kill", Nothing);
return Val_unit;
#else
CAMLprim value unix_listen(value sock, value backlog)
-{ invalid_argument("listen not implemented"); }
+{ caml_invalid_argument("listen not implemented"); }
#endif
break;
case 1: /* F_LOCK */
l.l_type = F_WRLCK;
- enter_blocking_section();
+ caml_enter_blocking_section();
ret = fcntl(fildes, F_SETLKW, &l);
- leave_blocking_section();
+ caml_leave_blocking_section();
break;
case 2: /* F_TLOCK */
l.l_type = F_WRLCK;
break;
case 4: /* F_RLOCK */
l.l_type = F_RDLCK;
- enter_blocking_section();
+ caml_enter_blocking_section();
ret = fcntl(fildes, F_SETLKW, &l);
- leave_blocking_section();
+ caml_leave_blocking_section();
break;
case 5: /* F_TRLOCK */
l.l_type = F_RDLCK;
#else
CAMLprim value unix_lockf(value fd, value cmd, value span)
-{ invalid_argument("lockf not implemented"); }
+{ caml_invalid_argument("lockf not implemented"); }
#endif
#endif
CAMLprim value unix_mkfifo(value path, value mode)
{
- invalid_argument("mkfifo not implemented");
+ caml_invalid_argument("mkfifo not implemented");
}
#endif
#ifndef O_RSYNC
#define O_RSYNC 0
#endif
-#ifndef O_CLOEXEC
-#define NEED_CLOEXEC_EMULATION
-#define O_CLOEXEC 0
-#endif
-static int open_flag_table[14] = {
+static int open_flag_table[15] = {
O_RDONLY, O_WRONLY, O_RDWR, O_NONBLOCK, O_APPEND, O_CREAT, O_TRUNC, O_EXCL,
O_NOCTTY, O_DSYNC, O_SYNC, O_RSYNC,
0, /* O_SHARE_DELETE, Windows-only */
- O_CLOEXEC
+ 0, /* O_CLOEXEC, treated specially */
+ 0 /* O_KEEPEXEC, treated specially */
};
-#ifdef NEED_CLOEXEC_EMULATION
-static int open_cloexec_table[14] = {
+enum { CLOEXEC = 1, KEEPEXEC = 2 };
+
+static int open_cloexec_table[15] = {
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0,
0,
- 1
+ CLOEXEC, KEEPEXEC
};
-#endif
CAMLprim value unix_open(value path, value flags, value perm)
{
CAMLparam3(path, flags, perm);
- int fd, cv_flags;
+ int fd, cv_flags, clo_flags, cloexec;
char * p;
caml_unix_check_path(path, "open");
- cv_flags = convert_flag_list(flags, open_flag_table);
+ cv_flags = caml_convert_flag_list(flags, open_flag_table);
+ clo_flags = caml_convert_flag_list(flags, open_cloexec_table);
+ if (clo_flags & CLOEXEC)
+ cloexec = 1;
+ else if (clo_flags & KEEPEXEC)
+ cloexec = 0;
+ else
+ cloexec = unix_cloexec_default;
+#if defined(O_CLOEXEC)
+ if (cloexec) cv_flags |= O_CLOEXEC;
+#endif
p = caml_strdup(String_val(path));
/* open on a named FIFO can block (PR#1533) */
- enter_blocking_section();
+ caml_enter_blocking_section();
fd = open(p, cv_flags, Int_val(perm));
- leave_blocking_section();
- stat_free(p);
+ caml_leave_blocking_section();
+ caml_stat_free(p);
if (fd == -1) uerror("open", path);
-#if defined(NEED_CLOEXEC_EMULATION) && defined(FD_CLOEXEC)
- if (convert_flag_list(flags, open_cloexec_table) != 0) {
- int flags = fcntl(fd, F_GETFD, 0);
- if (flags == -1 ||
- fcntl(fd, F_SETFD, flags | FD_CLOEXEC) == -1)
- uerror("open", path);
- }
+#if !defined(O_CLOEXEC)
+ if (cloexec) unix_set_cloexec(fd, "open", path);
#endif
CAMLreturn (Val_int(fd));
}
caml_leave_blocking_section();
caml_stat_free(p);
if (d == (DIR *) NULL) uerror("opendir", path);
- res = alloc_small(1, Abstract_tag);
+ res = caml_alloc_small(1, Abstract_tag);
DIR_Val(res) = d;
CAMLreturn(res);
}
/* */
/**************************************************************************/
+#define _GNU_SOURCE
#include <caml/mlvalues.h>
#include <caml/alloc.h>
#include "unixsupport.h"
+#include <fcntl.h>
-CAMLprim value unix_pipe(value unit)
+CAMLprim value unix_pipe(value cloexec, value vunit)
{
int fd[2];
value res;
+#ifdef HAS_PIPE2
+ if (pipe2(fd, unix_cloexec_p(cloexec) ? O_CLOEXEC : 0) == -1)
+ uerror("pipe", Nothing);
+#else
if (pipe(fd) == -1) uerror("pipe", Nothing);
- res = alloc_small(2, 0);
+ if (unix_cloexec_p(cloexec)) {
+ unix_set_cloexec(fd[0], "pipe", Nothing);
+ unix_set_cloexec(fd[1], "pipe", Nothing);
+ }
+#endif
+ res = caml_alloc_small(2, 0);
Field(res, 0) = Val_int(fd[0]);
Field(res, 1) = Val_int(fd[1]);
return res;
CAMLprim value unix_putenv(value name, value val)
{
- mlsize_t namelen = string_length(name);
- mlsize_t vallen = string_length(val);
+ mlsize_t namelen = caml_string_length(name);
+ mlsize_t vallen = caml_string_length(val);
char * s;
if (! (caml_string_is_c_safe(name) && caml_string_is_c_safe(val)))
#else
CAMLprim value unix_putenv(value name, value val)
-{ invalid_argument("putenv not implemented"); }
+{ caml_invalid_argument("putenv not implemented"); }
#endif
Begin_root (buf);
numbytes = Long_val(len);
if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
- enter_blocking_section();
+ caml_enter_blocking_section();
ret = read(Int_val(fd), iobuf, (int) numbytes);
- leave_blocking_section();
+ caml_leave_blocking_section();
if (ret == -1) uerror("read", Nothing);
memmove (&Byte(buf, Long_val(ofs)), iobuf, ret);
End_roots();
caml_enter_blocking_section();
e = readdir((DIR *) d);
caml_leave_blocking_section();
- if (e == (directory_entry *) NULL) raise_end_of_file();
- return copy_string(e->d_name);
+ if (e == (directory_entry *) NULL) caml_raise_end_of_file();
+ return caml_copy_string(e->d_name);
}
caml_stat_free(p);
if (len == -1) uerror("readlink", path);
buffer[len] = '\0';
- CAMLreturn(copy_string(buffer));
+ CAMLreturn(caml_copy_string(buffer));
}
#else
CAMLprim value unix_readlink(value path)
-{ invalid_argument("readlink not implemented"); }
+{ caml_invalid_argument("readlink not implemented"); }
#endif
#else
CAMLprim value unix_rewinddir(value d)
-{ invalid_argument("rewinddir not implemented"); }
+{ caml_invalid_argument("rewinddir not implemented"); }
#endif
for (l = fdlist; l != Val_int(0); l = Field(l, 1)) {
int fd = Int_val(Field(l, 0));
if (FD_ISSET(fd, fdset)) {
- value newres = alloc_small(2, 0);
+ value newres = caml_alloc_small(2, 0);
Field(newres, 0) = Val_int(fd);
Field(newres, 1) = res;
res = newres;
tv.tv_usec = (int) (1e6 * (tm - tv.tv_sec));
tvp = &tv;
}
- enter_blocking_section();
+ caml_enter_blocking_section();
retcode = select(maxfd + 1, &read, &write, &except, tvp);
- leave_blocking_section();
+ caml_leave_blocking_section();
if (retcode == -1) uerror("select", Nothing);
readfds = fdset_to_fdlist(readfds, &read);
writefds = fdset_to_fdlist(writefds, &write);
exceptfds = fdset_to_fdlist(exceptfds, &except);
- res = alloc_small(3, 0);
+ res = caml_alloc_small(3, 0);
Field(res, 0) = readfds;
Field(res, 1) = writefds;
Field(res, 2) = exceptfds;
CAMLprim value unix_select(value readfds, value writefds, value exceptfds,
value timeout)
-{ invalid_argument("select not implemented"); }
+{ caml_invalid_argument("select not implemented"); }
#endif
long numbytes;
char iobuf[UNIX_BUFFER_SIZE];
- cv_flags = convert_flag_list(flags, msg_flag_table);
+ cv_flags = caml_convert_flag_list(flags, msg_flag_table);
Begin_root (buff);
numbytes = Long_val(len);
if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
- enter_blocking_section();
+ caml_enter_blocking_section();
ret = recv(Int_val(sock), iobuf, (int) numbytes, cv_flags);
- leave_blocking_section();
+ caml_leave_blocking_section();
if (ret == -1) uerror("recv", Nothing);
memmove (&Byte(buff, Long_val(ofs)), iobuf, ret);
End_roots();
union sock_addr_union addr;
socklen_param_type addr_len;
- cv_flags = convert_flag_list(flags, msg_flag_table);
+ cv_flags = caml_convert_flag_list(flags, msg_flag_table);
Begin_roots2 (buff, adr);
numbytes = Long_val(len);
if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
addr_len = sizeof(addr);
- enter_blocking_section();
+ caml_enter_blocking_section();
ret = recvfrom(Int_val(sock), iobuf, (int) numbytes, cv_flags,
&addr.s_gen, &addr_len);
- leave_blocking_section();
+ caml_leave_blocking_section();
if (ret == -1) uerror("recvfrom", Nothing);
memmove (&Byte(buff, Long_val(ofs)), iobuf, ret);
adr = alloc_sockaddr(&addr, addr_len, -1);
- res = alloc_small(2, 0);
+ res = caml_alloc_small(2, 0);
Field(res, 0) = Val_int(ret);
Field(res, 1) = adr;
End_roots();
long numbytes;
char iobuf[UNIX_BUFFER_SIZE];
- cv_flags = convert_flag_list(flags, msg_flag_table);
+ cv_flags = caml_convert_flag_list(flags, msg_flag_table);
numbytes = Long_val(len);
if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
memmove (iobuf, &Byte(buff, Long_val(ofs)), numbytes);
- enter_blocking_section();
+ caml_enter_blocking_section();
ret = send(Int_val(sock), iobuf, (int) numbytes, cv_flags);
- leave_blocking_section();
+ caml_leave_blocking_section();
if (ret == -1) uerror("send", Nothing);
return Val_int(ret);
}
union sock_addr_union addr;
socklen_param_type addr_len;
- cv_flags = convert_flag_list(flags, msg_flag_table);
+ cv_flags = caml_convert_flag_list(flags, msg_flag_table);
get_sockaddr(dest, &addr, &addr_len);
numbytes = Long_val(len);
if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
memmove (iobuf, &Byte(buff, Long_val(ofs)), numbytes);
- enter_blocking_section();
+ caml_enter_blocking_section();
ret = sendto(Int_val(sock), iobuf, (int) numbytes, cv_flags,
&addr.s_gen, addr_len);
- leave_blocking_section();
+ caml_leave_blocking_section();
if (ret == -1) uerror("sendto", Nothing);
return Val_int(ret);
}
CAMLprim value unix_recv(value sock, value buff, value ofs, value len,
value flags)
-{ invalid_argument("recv not implemented"); }
+{ caml_invalid_argument("recv not implemented"); }
CAMLprim value unix_recvfrom(value sock, value buff, value ofs, value len,
value flags)
-{ invalid_argument("recvfrom not implemented"); }
+{ caml_invalid_argument("recvfrom not implemented"); }
CAMLprim value unix_send(value sock, value buff, value ofs, value len,
value flags)
-{ invalid_argument("send not implemented"); }
+{ caml_invalid_argument("send not implemented"); }
CAMLprim value unix_sendto_native(value sock, value buff, value ofs, value len,
value flags, value dest)
-{ invalid_argument("sendto not implemented"); }
+{ caml_invalid_argument("sendto not implemented"); }
CAMLprim value unix_sendto(value *argv, int argc)
-{ invalid_argument("sendto not implemented"); }
+{ caml_invalid_argument("sendto not implemented"); }
#endif
n = setgroups(size, gidset);
- stat_free(gidset);
+ caml_stat_free(gidset);
if (n == -1) uerror("setgroups", Nothing);
return Val_unit;
}
#else
CAMLprim value unix_setgroups(value groups)
-{ invalid_argument("setgroups not implemented"); }
+{ caml_invalid_argument("setgroups not implemented"); }
#endif
#ifdef HAS_SETSID
return Val_int(setsid());
#else
- invalid_argument("setsid not implemented");
+ caml_invalid_argument("setsid not implemented");
return Val_unit;
#endif
}
#else
CAMLprim value unix_shutdown(value sock, value cmd)
-{ invalid_argument("shutdown not implemented"); }
+{ caml_invalid_argument("shutdown not implemented"); }
#endif
Begin_root(res)
for (i = 1; i < NSIG; i++)
if (sigismember(set, i) > 0) {
- value newcons = alloc_small(2, 0);
+ value newcons = caml_alloc_small(2, 0);
Field(newcons, 0) = Val_int(caml_rev_convert_signal_number(i));
Field(newcons, 1) = res;
res = newcons;
how = sigprocmask_cmd[Int_val(vaction)];
decode_sigset(vset, &set);
- enter_blocking_section();
+ caml_enter_blocking_section();
retcode = sigprocmask(how, &set, &oldset);
- leave_blocking_section();
+ caml_leave_blocking_section();
if (retcode == -1) uerror("sigprocmask", Nothing);
return encode_sigset(&oldset);
}
sigset_t set;
int retcode;
decode_sigset(vset, &set);
- enter_blocking_section();
+ caml_enter_blocking_section();
retcode = sigsuspend(&set);
- leave_blocking_section();
+ caml_leave_blocking_section();
if (retcode == -1 && errno != EINTR) uerror("sigsuspend", Nothing);
return Val_unit;
}
#else
CAMLprim value unix_sigprocmask(value vaction, value vset)
-{ invalid_argument("Unix.sigprocmask not available"); }
+{ caml_invalid_argument("Unix.sigprocmask not available"); }
CAMLprim value unix_sigpending(value unit)
-{ invalid_argument("Unix.sigpending not available"); }
+{ caml_invalid_argument("Unix.sigpending not available"); }
CAMLprim value unix_sigsuspend(value vset)
-{ invalid_argument("Unix.sigsuspend not available"); }
+{ caml_invalid_argument("Unix.sigsuspend not available"); }
#endif
{
struct timespec t;
int ret;
- enter_blocking_section();
+ caml_enter_blocking_section();
t.tv_sec = (time_t) d;
t.tv_nsec = (d - t.tv_sec) * 1e9;
do {
ret = nanosleep(&t, &t);
} while (ret == -1 && errno == EINTR);
- leave_blocking_section();
+ caml_leave_blocking_section();
if (ret == -1) uerror("sleep", Nothing);
}
#elif defined(HAS_SELECT)
{
struct timeval t;
int ret;
- enter_blocking_section();
+ caml_enter_blocking_section();
t.tv_sec = (time_t) d;
t.tv_usec = (d - t.tv_sec) * 1e6;
do {
ret = select(0, NULL, NULL, NULL, &t);
} while (ret == -1 && errno == EINTR);
- leave_blocking_section();
+ caml_leave_blocking_section();
if (ret == -1) uerror("sleep", Nothing);
}
#else
We cannot reliably iterate until sleep() returns 0, because the
remaining time returned by sleep() is generally rounded up. */
{
- enter_blocking_section();
+ caml_enter_blocking_section();
sleep ((unsigned int) d);
- leave_blocking_section();
+ caml_leave_blocking_section();
}
#endif
return Val_unit;
/* */
/**************************************************************************/
+#define _GNU_SOURCE
#include <caml/fail.h>
#include <caml/mlvalues.h>
#include "unixsupport.h"
SOCK_STREAM, SOCK_DGRAM, SOCK_RAW, SOCK_SEQPACKET
};
-CAMLprim value unix_socket(value domain, value type, value proto)
+CAMLprim value unix_socket(value cloexec, value domain,
+ value type, value proto)
{
int retcode;
+ int ty = socket_type_table[Int_val(type)];
+#ifdef SOCK_CLOEXEC
+ if (unix_cloexec_p(cloexec)) ty |= SOCK_CLOEXEC;
+#endif
retcode = socket(socket_domain_table[Int_val(domain)],
- socket_type_table[Int_val(type)],
- Int_val(proto));
+ ty, Int_val(proto));
if (retcode == -1) uerror("socket", Nothing);
+#ifndef SOCK_CLOEXEC
+ if (unix_cloexec_p(cloexec))
+ unix_set_cloexec(retcode, "socket", Nothing);
+#endif
return Val_int(retcode);
-
}
#else
-CAMLprim value unix_socket(value domain, value type, value proto)
-{ invalid_argument("socket not implemented"); }
+CAMLprim value unix_socket(value cloexec, value domain,
+ value type,value proto)
+{ caml_invalid_argument("socket not implemented"); }
#endif
/* Use a string rather than an abstract block so that it can be
marshaled safely. Remember that a is in network byte order,
hence is marshaled in an endian-independent manner. */
- res = alloc_string(4);
+ res = caml_alloc_string(4);
memcpy(String_val(res), a, 4);
return res;
}
CAMLexport value alloc_inet6_addr(struct in6_addr * a)
{
value res;
- res = alloc_string(16);
+ res = caml_alloc_string(16);
memcpy(String_val(res), a, 16);
return res;
}
{ value path;
mlsize_t len;
path = Field(mladr, 0);
- len = string_length(path);
+ len = caml_string_length(path);
adr->s_unix.sun_family = AF_UNIX;
if (len >= sizeof(adr->s_unix.sun_path)) {
unix_error(ENAMETOOLONG, "", path);
#endif
case 1: /* ADDR_INET */
#ifdef HAS_IPV6
- if (string_length(Field(mladr, 0)) == 16) {
+ if (caml_string_length(Field(mladr, 0)) == 16) {
memset(&adr->s_inet6, 0, sizeof(struct sockaddr_in6));
adr->s_inet6.sin6_family = AF_INET6;
adr->s_inet6.sin6_addr = GET_INET6_ADDR(Field(mladr, 0));
switch(adr->s_gen.sa_family) {
#ifndef _WIN32
case AF_UNIX:
- { char * path;
- value n;
- /* PR#7039: harden against unnamed sockets */
- if (adr_len > (char *)&(adr->s_unix.sun_path) - (char *)&(adr->s_unix))
- path = adr->s_unix.sun_path;
- else
- path = "";
- n = copy_string(path);
+ { value n;
+ /* Based on recommendation in section BUGS of Linux unix(7). See
+ http://man7.org/linux/man-pages/man7/unix.7.html */
+ mlsize_t path_length =
+ strnlen(adr->s_unix.sun_path,
+ adr_len - offsetof(struct sockaddr_un, sun_path));
+ n = caml_alloc_string(path_length);
+ memmove(String_val(n), adr->s_unix.sun_path, path_length);
Begin_root (n);
- res = alloc_small(1, 0);
+ res = caml_alloc_small(1, 0);
Field(res,0) = n;
End_roots();
break;
case AF_INET:
{ value a = alloc_inet_addr(&adr->s_inet.sin_addr);
Begin_root (a);
- res = alloc_small(2, 1);
+ res = caml_alloc_small(2, 1);
Field(res,0) = a;
Field(res,1) = Val_int(ntohs(adr->s_inet.sin_port));
End_roots();
case AF_INET6:
{ value a = alloc_inet6_addr(&adr->s_inet6.sin6_addr);
Begin_root (a);
- res = alloc_small(2, 1);
+ res = caml_alloc_small(2, 1);
Field(res,0) = a;
Field(res,1) = Val_int(ntohs(adr->s_inet6.sin6_port));
End_roots();
extern int socket_domain_table[], socket_type_table[];
-CAMLprim value unix_socketpair(value domain, value type, value proto)
+CAMLprim value unix_socketpair(value cloexec, value domain,
+ value type, value proto)
{
int sv[2];
value res;
+ int ty = socket_type_table[Int_val(type)];
+#ifdef SOCK_CLOEXEC
+ if (unix_cloexec_p(cloexec)) ty |= SOCK_CLOEXEC;
+#endif
if (socketpair(socket_domain_table[Int_val(domain)],
- socket_type_table[Int_val(type)],
- Int_val(proto), sv) == -1)
+ ty, Int_val(proto), sv) == -1)
uerror("socketpair", Nothing);
- res = alloc_small(2, 0);
+#ifndef SOCK_CLOEXEC
+ if (unix_cloexec_p(cloexec)) {
+ unix_set_cloexec(sv[0], "socketpair", Nothing);
+ unix_set_cloexec(sv[1], "socketpair", Nothing);
+ }
+#endif
+ res = caml_alloc_small(2, 0);
Field(res,0) = Val_int(sv[0]);
Field(res,1) = Val_int(sv[1]);
return res;
#else
CAMLprim value unix_socketpair(value domain, value type, value proto)
-{ invalid_argument("socketpair not implemented"); }
+{ caml_invalid_argument("socketpair not implemented"); }
#endif
if (optval.lg.l_onoff == 0) {
return Val_int(0); /* None */
} else {
- value res = alloc_small(1, 0); /* Some */
+ value res = caml_alloc_small(1, 0); /* Some */
Field(res, 0) = Val_int(optval.lg.l_linger);
return res;
}
case TYPE_TIMEVAL:
- return copy_double((double) optval.tv.tv_sec
+ return caml_copy_double((double) optval.tv.tv_sec
+ (double) optval.tv.tv_usec / 1e6);
case TYPE_UNIX_ERROR:
if (optval.i == 0) {
value err, res;
err = unix_error_of_code(optval.i);
Begin_root(err);
- res = alloc_small(1, 0); /* Some */
+ res = caml_alloc_small(1, 0); /* Some */
Field(res, 0) = err;
End_roots();
return res;
#else
CAMLprim value unix_getsockopt(value vty, value socket, value option)
-{ invalid_argument("getsockopt not implemented"); }
+{ caml_invalid_argument("getsockopt not implemented"); }
CAMLprim value unix_setsockopt(value vty, value socket, value option, value val)
-{ invalid_argument("setsockopt not implemented"); }
+{ caml_invalid_argument("setsockopt not implemented"); }
#endif
+ (NSEC(buf, c) / 1000000000.0));
#undef NSEC
offset = use_64 ? Val_file_offset(buf->st_size) : Val_int (buf->st_size);
- v = alloc_small(12, 0);
+ v = caml_alloc_small(12, 0);
Field (v, 0) = Val_int (buf->st_dev);
Field (v, 1) = Val_int (buf->st_ino);
Field (v, 2) = cst_to_constr(buf->st_mode & S_IFMT, file_kind_table,
union sock_addr_union sa;
int len;
int retcode;
- if (string_length(a) == 16) {
+ if (caml_string_length(a) == 16) {
memset(&sa.s_inet6, 0, sizeof(struct sockaddr_in6));
sa.s_inet6.sin6_family = AF_INET6;
sa.s_inet6.sin6_addr = GET_INET6_ADDR(a);
res = buffer;
#else
char buffer[64];
- if (string_length(a) == 16)
+ if (caml_string_length(a) == 16)
res = (char *)
inet_ntop(AF_INET6, (const void *) &GET_INET6_ADDR(a),
buffer, sizeof(buffer));
res = inet_ntoa(GET_INET_ADDR(a));
#endif
if (res == NULL) uerror("string_of_inet_addr", Nothing);
- return copy_string(res);
+ return caml_copy_string(res);
}
#else
CAMLprim value unix_string_of_inet_addr(value a)
-{ invalid_argument("string_of_inet_addr not implemented"); }
+{ caml_invalid_argument("string_of_inet_addr not implemented"); }
#endif
#else
CAMLprim value unix_symlink(value to_dir, value path1, value path2)
-{ invalid_argument("symlink not implemented"); }
+{ caml_invalid_argument("symlink not implemented"); }
CAMLprim value unix_has_symlink(value unit)
{
if (tcgetattr(Int_val(fd), &terminal_status) == -1)
uerror("tcgetattr", Nothing);
- res = alloc_tuple(NFIELDS);
+ res = caml_alloc_tuple(NFIELDS);
encode_terminal_status(&Field(res, 0));
return res;
}
#if defined(__ANDROID__)
CAMLprim value unix_tcdrain(value fd)
-{ invalid_argument("tcdrain not implemented"); }
+{ caml_invalid_argument("tcdrain not implemented"); }
#else
CAMLprim value unix_tcdrain(value fd)
{
#else
CAMLprim value unix_tcgetattr(value fd)
-{ invalid_argument("tcgetattr not implemented"); }
+{ caml_invalid_argument("tcgetattr not implemented"); }
CAMLprim value unix_tcsetattr(value fd, value when, value arg)
-{ invalid_argument("tcsetattr not implemented"); }
+{ caml_invalid_argument("tcsetattr not implemented"); }
CAMLprim value unix_tcsendbreak(value fd, value delay)
-{ invalid_argument("tcsendbreak not implemented"); }
+{ caml_invalid_argument("tcsendbreak not implemented"); }
CAMLprim value unix_tcdrain(value fd)
-{ invalid_argument("tcdrain not implemented"); }
+{ caml_invalid_argument("tcdrain not implemented"); }
CAMLprim value unix_tcflush(value fd, value queue)
-{ invalid_argument("tcflush not implemented"); }
+{ caml_invalid_argument("tcflush not implemented"); }
CAMLprim value unix_tcflow(value fd, value action)
-{ invalid_argument("tcflow not implemented"); }
+{ caml_invalid_argument("tcflow not implemented"); }
#endif
CAMLprim value unix_time(value unit)
{
- return copy_double((double) time((time_t *) NULL));
+ return caml_copy_double((double) time((time_t *) NULL));
}
value res;
struct rusage ru;
- res = alloc_small(4 * Double_wosize, Double_array_tag);
+ res = caml_alloc_small(4 * Double_wosize, Double_array_tag);
getrusage (RUSAGE_SELF, &ru);
Store_double_field (res, 0, ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1e6);
struct tms buffer;
times(&buffer);
- res = alloc_small(4 * Double_wosize, Double_array_tag);
+ res = caml_alloc_small(4 * Double_wosize, Double_array_tag);
Store_double_field(res, 0, (double) buffer.tms_utime / CLK_TCK);
Store_double_field(res, 1, (double) buffer.tms_stime / CLK_TCK);
Store_double_field(res, 2, (double) buffer.tms_cutime / CLK_TCK);
#else
CAMLprim value unix_truncate(value path, value len)
-{ invalid_argument("truncate not implemented"); }
+{ caml_invalid_argument("truncate not implemented"); }
CAMLprim value unix_truncate_64(value path, value len)
-{ invalid_argument("truncate not implemented"); }
+{ caml_invalid_argument("truncate not implemented"); }
#endif
external environment : unit -> string array = "unix_environment"
external getenv: string -> string = "caml_sys_getenv"
+(* external unsafe_getenv: string -> string = "caml_sys_unsafe_getenv" *)
external putenv: string -> string -> unit = "unix_putenv"
type process_status =
| O_RSYNC
| O_SHARE_DELETE
| O_CLOEXEC
+ | O_KEEPEXEC
type file_perm = int
external umask : int -> int = "unix_umask"
external access : string -> access_permission list -> unit = "unix_access"
-external dup : file_descr -> file_descr = "unix_dup"
-external dup2 : file_descr -> file_descr -> unit = "unix_dup2"
+external dup : ?cloexec: bool -> file_descr -> file_descr = "unix_dup"
+external dup2 :
+ ?cloexec: bool -> file_descr -> file_descr -> unit = "unix_dup2"
external set_nonblock : file_descr -> unit = "unix_set_nonblock"
external clear_nonblock : file_descr -> unit = "unix_clear_nonblock"
external set_close_on_exec : file_descr -> unit = "unix_set_close_on_exec"
external clear_close_on_exec : file_descr -> unit = "unix_clear_close_on_exec"
-(* FD_CLOEXEC should be supported on all Unix systems these days,
- but just in case... *)
-let try_set_close_on_exec fd =
- try set_close_on_exec fd; true with Invalid_argument _ -> false
-
external mkdir : string -> file_perm -> unit = "unix_mkdir"
external rmdir : string -> unit = "unix_rmdir"
external chdir : string -> unit = "unix_chdir"
external rewinddir : dir_handle -> unit = "unix_rewinddir"
external closedir : dir_handle -> unit = "unix_closedir"
-external pipe : unit -> file_descr * file_descr = "unix_pipe"
+external pipe :
+ ?cloexec: bool -> unit -> file_descr * file_descr = "unix_pipe"
external symlink : ?to_dir:bool -> string -> string -> unit = "unix_symlink"
external has_symlink : unit -> bool = "unix_has_symlink"
external readlink : string -> string = "unix_readlink"
| MSG_DONTROUTE
| MSG_PEEK
-external socket : socket_domain -> socket_type -> int -> file_descr
- = "unix_socket"
+external socket :
+ ?cloexec: bool -> socket_domain -> socket_type -> int -> file_descr
+ = "unix_socket"
external socketpair :
- socket_domain -> socket_type -> int -> file_descr * file_descr
- = "unix_socketpair"
-external accept : file_descr -> file_descr * sockaddr = "unix_accept"
+ ?cloexec: bool -> socket_domain -> socket_type -> int ->
+ file_descr * file_descr
+ = "unix_socketpair"
+external accept :
+ ?cloexec: bool -> file_descr -> file_descr * sockaddr = "unix_accept"
external bind : file_descr -> sockaddr -> unit = "unix_bind"
external connect : file_descr -> sockaddr -> unit = "unix_connect"
external listen : file_descr -> int -> unit = "unix_listen"
end
| id -> snd(waitpid_non_intr id)
-let rec safe_dup fd =
- let new_fd = dup fd in
- if new_fd >= 3 then
- new_fd
- else begin
- let res = safe_dup fd in
- close new_fd;
- res
- end
+(* Duplicate [fd] if needed to make sure it isn't one of the
+ standard descriptors (stdin, stdout, stderr).
+ Note that this function always leaves the standard descriptors open,
+ the caller must take care of closing them if needed.
+ The "cloexec" mode doesn't matter, because
+ the descriptor returned by [dup] will be closed before the [exec],
+ and because no other thread is running concurrently
+ (we are in the child process of a fork).
+ *)
+let rec file_descr_not_standard fd =
+ if fd >= 3 then fd else file_descr_not_standard (dup fd)
let safe_close fd =
try close fd with Unix_error(_,_,_) -> ()
let perform_redirections new_stdin new_stdout new_stderr =
- let newnewstdin = safe_dup new_stdin in
- let newnewstdout = safe_dup new_stdout in
- let newnewstderr = safe_dup new_stderr in
+ let new_stdin = file_descr_not_standard new_stdin in
+ let new_stdout = file_descr_not_standard new_stdout in
+ let new_stderr = file_descr_not_standard new_stderr in
+ (* The three dup2 close the original stdin, stdout, stderr,
+ which are the descriptors possibly left open
+ by file_descr_not_standard *)
+ dup2 ~cloexec:false new_stdin stdin;
+ dup2 ~cloexec:false new_stdout stdout;
+ dup2 ~cloexec:false new_stderr stderr;
safe_close new_stdin;
safe_close new_stdout;
- safe_close new_stderr;
- dup2 newnewstdin stdin; close newnewstdin;
- dup2 newnewstdout stdout; close newnewstdout;
- dup2 newnewstderr stderr; close newnewstderr
+ safe_close new_stderr
let create_process cmd args new_stdin new_stdout new_stderr =
match fork() with
let popen_processes = (Hashtbl.create 7 : (popen_process, int) Hashtbl.t)
-let open_proc cmd proc input output toclose =
- let cloexec = List.for_all try_set_close_on_exec toclose in
- match fork() with
- 0 -> begin try
- if input <> stdin then begin dup2 input stdin; close input end;
- if output <> stdout then begin dup2 output stdout; close output end;
- if not cloexec then List.iter close toclose;
- execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]
- with _ -> sys_exit 127
+let open_proc cmd envopt proc input output error =
+ match fork() with
+ 0 -> perform_redirections input output error;
+ let shell = "/bin/sh" in
+ let argv = [| shell; "-c"; cmd |] in
+ begin try
+ match envopt with
+ | Some env -> execve shell argv env
+ | None -> execv shell argv
+ with _ ->
+ sys_exit 127
end
- | id -> Hashtbl.add popen_processes proc id
+ | id -> Hashtbl.add popen_processes proc id
let open_process_in cmd =
- let (in_read, in_write) = pipe() in
+ let (in_read, in_write) = pipe ~cloexec:true () in
let inchan = in_channel_of_descr in_read in
begin
try
- open_proc cmd (Process_in inchan) stdin in_write [in_read];
+ open_proc cmd None (Process_in inchan) stdin in_write stderr
with e ->
close_in inchan;
close in_write;
inchan
let open_process_out cmd =
- let (out_read, out_write) = pipe() in
+ let (out_read, out_write) = pipe ~cloexec:true () in
let outchan = out_channel_of_descr out_write in
begin
try
- open_proc cmd (Process_out outchan) out_read stdout [out_write];
+ open_proc cmd None (Process_out outchan) out_read stdout stderr
with e ->
- close_out outchan;
- close out_read;
- raise e
+ close_out outchan;
+ close out_read;
+ raise e
end;
close out_read;
outchan
let open_process cmd =
- let (in_read, in_write) = pipe() in
- let fds_to_close = ref [in_read;in_write] in
- try
- let (out_read, out_write) = pipe() in
- fds_to_close := [in_read;in_write;out_read;out_write];
- let inchan = in_channel_of_descr in_read in
- let outchan = out_channel_of_descr out_write in
- open_proc cmd (Process(inchan, outchan)) out_read in_write
- [in_read; out_write];
- close out_read;
- close in_write;
- (inchan, outchan)
- with e ->
- List.iter close !fds_to_close;
- raise e
-
-let open_proc_full cmd env proc input output error toclose =
- let cloexec = List.for_all try_set_close_on_exec toclose in
- match fork() with
- 0 -> begin try
- dup2 input stdin; close input;
- dup2 output stdout; close output;
- dup2 error stderr; close error;
- if not cloexec then List.iter close toclose;
- execve "/bin/sh" [| "/bin/sh"; "-c"; cmd |] env
- with _ -> sys_exit 127
- end
- | id -> Hashtbl.add popen_processes proc id
+ let (in_read, in_write) = pipe ~cloexec:true () in
+ let (out_read, out_write) =
+ try pipe ~cloexec:true ()
+ with e -> close in_read; close in_write; raise e in
+ let inchan = in_channel_of_descr in_read in
+ let outchan = out_channel_of_descr out_write in
+ begin
+ try
+ open_proc cmd None (Process(inchan, outchan)) out_read in_write stderr
+ with e ->
+ close out_read; close out_write;
+ close in_read; close in_write;
+ raise e
+ end;
+ close out_read;
+ close in_write;
+ (inchan, outchan)
let open_process_full cmd env =
- let (in_read, in_write) = pipe() in
- let fds_to_close = ref [in_read;in_write] in
- try
- let (out_read, out_write) = pipe() in
- fds_to_close := out_read::out_write:: !fds_to_close;
- let (err_read, err_write) = pipe() in
- fds_to_close := err_read::err_write:: !fds_to_close;
- let inchan = in_channel_of_descr in_read in
- let outchan = out_channel_of_descr out_write in
- let errchan = in_channel_of_descr err_read in
- open_proc_full cmd env (Process_full(inchan, outchan, errchan))
- out_read in_write err_write [in_read; out_write; err_read];
- close out_read;
- close in_write;
- close err_write;
- (inchan, outchan, errchan)
- with e ->
- List.iter close !fds_to_close;
- raise e
+ let (in_read, in_write) = pipe ~cloexec:true () in
+ let (out_read, out_write) =
+ try pipe ~cloexec:true ()
+ with e -> close in_read; close in_write; raise e in
+ let (err_read, err_write) =
+ try pipe ~cloexec:true ()
+ with e -> close in_read; close in_write;
+ close out_read; close out_write; raise e in
+ let inchan = in_channel_of_descr in_read in
+ let outchan = out_channel_of_descr out_write in
+ let errchan = in_channel_of_descr err_read in
+ begin
+ try
+ open_proc cmd (Some env) (Process_full(inchan, outchan, errchan))
+ out_read in_write err_write
+ with e ->
+ close out_read; close out_write;
+ close in_read; close in_write;
+ close err_read; close err_write;
+ raise e
+ end;
+ close out_read;
+ close in_write;
+ close err_write;
+ (inchan, outchan, errchan)
let find_proc_id fun_name proc =
try
let close_process_out outchan =
let pid = find_proc_id "close_process_out" (Process_out outchan) in
- close_out outchan;
+ (* The application may have closed [outchan] already to signal
+ end-of-input to the process. *)
+ begin try close_out outchan with Sys_error _ -> () end;
snd(waitpid_non_intr pid)
let close_process (inchan, outchan) =
let open_connection sockaddr =
let sock =
- socket (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
+ socket ~cloexec:true (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
try
connect sock sockaddr;
- ignore(try_set_close_on_exec sock);
(in_channel_of_descr sock, out_channel_of_descr sock)
with exn ->
close sock; raise exn
shutdown (descr_of_in_channel inchan) SHUTDOWN_SEND
let rec accept_non_intr s =
- try accept s
+ try accept ~cloexec:true s
with Unix_error (EINTR, _, _) -> accept_non_intr s
let establish_server server_fun sockaddr =
let sock =
- socket (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
+ socket ~cloexec:true (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
setsockopt sock SO_REUSEADDR true;
bind sock sockaddr;
listen sock 5;
0 -> if fork() <> 0 then sys_exit 0;
(* The son exits, the grandson works *)
close sock;
- ignore(try_set_close_on_exec s);
let inchan = in_channel_of_descr s in
let outchan = out_channel_of_descr s in
server_fun inchan outchan;
(** Interface to the Unix system.
- Note: all the functions of this module (except [error_message] and
- [handle_unix_error]) are liable to raise the [Unix_error]
+ Note: all the functions of this module (except {!error_message} and
+ {!handle_unix_error}) are liable to raise the {!Unix_error}
exception whenever the underlying system call signals an error. *)
val handle_unix_error : ('a -> 'b) -> 'a -> 'b
(** [handle_unix_error f x] applies [f] to [x] and returns the result.
- If the exception [Unix_error] is raised, it prints a message
+ If the exception {!Unix_error} is raised, it prints a message
describing the error and exits with code 2. *)
with the format ``variable=value''. *)
val getenv : string -> string
+(** Return the value associated to a variable in the process
+ environment, unless the process has special privileges.
+ @raise Not_found if the variable is unbound or the process has
+ special privileges.
+
+ (This function is identical to {!Sys.getenv}. *)
+
+(*
+val unsafe_getenv : string -> string
(** Return the value associated to a variable in the process
environment.
- @raise Not_found if the variable is unbound.
- (This function is identical to {!Sys.getenv}.) *)
+ Unlike {!getenv}, this function returns the value even if the
+ process has special privileges. It is considered unsafe because the
+ programmer of a setuid or setgid program must be careful to avoid
+ using maliciously crafted environment variables in the search path
+ for executables, the locations for temporary files or logs, and the
+ like.
+
+ @raise Not_found if the variable is unbound. *)
+*)
val putenv : string -> string -> unit
(** [Unix.putenv name value] sets the value associated to a
| O_SHARE_DELETE (** Windows only: allow the file to be deleted
while still open *)
| O_CLOEXEC (** Set the close-on-exec flag on the
- descriptor returned by {!openfile} *)
+ descriptor returned by {!openfile}.
+ See {!set_close_on_exec} for more
+ information. *)
+ | O_KEEPEXEC (** Clear the close-on-exec flag.
+ This is currently the default. *)
(** The flags to {!Unix.openfile}. *)
val write_substring : file_descr -> string -> int -> int -> int
(** Same as [write], but take the data from a string instead of a byte
- sequence. *)
+ sequence.
+ @since 4.02.0 *)
val single_write_substring : file_descr -> string -> int -> int -> int
(** Same as [single_write], but take the data from a string instead of
- a byte sequence. *)
+ a byte sequence.
+ @since 4.02.0 *)
(** {6 Interfacing with the standard input/output library} *)
regular integers (type [int]), thus allowing operating on files
whose sizes are greater than [max_int]. *)
-
(** {6 Operations on file names} *)
val unlink : string -> unit
-(** Removes the named file. *)
+(** Removes the named file.
+
+ If the named file is a directory, raises:
+ {ul
+ {- [EPERM] on POSIX compliant system}
+ {- [EISDIR] on Linux >= 2.1.132}
+ {- [EACCESS] on Windows}}
+*)
val rename : string -> string -> unit
(** [rename old new] changes the name of a file from [old] to [new]. *)
(** {6 Operations on file descriptors} *)
-val dup : file_descr -> file_descr
+val dup : ?cloexec:bool -> file_descr -> file_descr
(** Return a new file descriptor referencing the same file as
- the given descriptor. *)
+ the given descriptor.
+ See {!set_close_on_exec} for documentation on the [cloexec]
+ optional argument. *)
-val dup2 : file_descr -> file_descr -> unit
+val dup2 : ?cloexec:bool -> file_descr -> file_descr -> unit
(** [dup2 fd1 fd2] duplicates [fd1] to [fd2], closing [fd2] if already
- opened. *)
+ opened.
+ See {!set_close_on_exec} for documentation on the [cloexec]
+ optional argument. *)
val set_nonblock : file_descr -> unit
(** Set the ``non-blocking'' flag on the given descriptor.
(** Set the ``close-on-exec'' flag on the given descriptor.
A descriptor with the close-on-exec flag is automatically
closed when the current process starts another program with
- one of the [exec] functions. *)
+ one of the [exec], [create_process] and [open_process] functions.
+
+ It is often a security hole to leak file descriptors opened on, say,
+ a private file to an external program: the program, then, gets access
+ to the private file and can do bad things with it. Hence, it is
+ highly recommended to set all file descriptors ``close-on-exec'',
+ except in the very few cases where a file descriptor actually needs
+ to be transmitted to another program.
+
+ The best way to set a file descriptor ``close-on-exec'' is to create
+ it in this state. To this end, the [openfile] function has
+ [O_CLOEXEC] and [O_KEEPEXEC] flags to enforce ``close-on-exec'' mode
+ or ``keep-on-exec'' mode, respectively. All other operations in
+ the Unix module that create file descriptors have an optional
+ argument [?cloexec:bool] to indicate whether the file descriptor
+ should be created in ``close-on-exec'' mode (by writing
+ [~cloexec:true]) or in ``keep-on-exec'' mode (by writing
+ [~cloexec:false]). For historical reasons, the default file
+ descriptor creation mode is ``keep-on-exec'', if no [cloexec] optional
+ argument is given. This is not a safe default, hence it is highly
+ recommended to pass explicit [cloexec] arguments to operations that
+ create file descriptors.
+
+ The [cloexec] optional arguments and the [O_KEEPEXEC] flag were introduced
+ in OCaml 4.05. Earlier, the common practice was to create file descriptors
+ in the default, ``keep-on-exec'' mode, then call [set_close_on_exec]
+ on those freshly-created file descriptors. This is not as safe as
+ creating the file descriptor in ``close-on-exec'' mode because, in
+ multithreaded programs, a window of vulnerability exists between the time
+ when the file descriptor is created and the time [set_close_on_exec]
+ completes. If another thread spawns another program during this window,
+ the descriptor will leak, as it is still in the ``keep-on-exec'' mode.
+
+ Regarding the atomicity guarantees given by [~cloexec:true] or by
+ the use of the [O_CLOEXEC] flag: on all platforms it is guaranteed
+ that a concurrently-executing Caml thread cannot leak the descriptor
+ by starting a new process. On Linux, this guarantee extends to
+ concurrently-executing C threads. As of Feb 2017, other operating
+ systems lack the necessary system calls and still expose a window
+ of vulnerability during which a C thread can see the newly-created
+ file descriptor in ``keep-on-exec'' mode.
+ *)
val clear_close_on_exec : file_descr -> unit
(** Clear the ``close-on-exec'' flag on the given descriptor.
(** {6 Pipes and redirections} *)
-val pipe : unit -> file_descr * file_descr
+val pipe : ?cloexec:bool -> unit -> file_descr * file_descr
(** Create a pipe. The first component of the result is opened
for reading, that's the exit to the pipe. The second component is
- opened for writing, that's the entrance to the pipe. *)
+ opened for writing, that's the entrance to the pipe.
+ See {!set_close_on_exec} for documentation on the [cloexec]
+ optional argument. *)
val mkfifo : string -> file_perm -> unit
(** Create a named pipe with the given permissions (see {!umask}).
points to a directory or a file; if omitted, [symlink] examines [source]
using [stat] and picks appropriately, if [source] does not exist then [false]
is assumed (for this reason, it is recommended that the [~to_dir] parameter
- be specified in new code). On Unix, [~to_dir] ignored.
+ be specified in new code). On Unix, [~to_dir] is ignored.
Windows symbolic links are available in Windows Vista onwards. There are some
important differences between Windows symlinks and their POSIX counterparts.
(** Returns [true] if the user is able to create symbolic links. On Windows,
this indicates that the user not only has the SeCreateSymbolicLinkPrivilege
but is also running elevated, if necessary. On other platforms, this is
- simply indicates that the symlink system call is available. *)
+ simply indicates that the symlink system call is available.
+ @since 4.03.0 *)
val readlink : string -> string
(** Read the contents of a symbolic link. *)
the specified region.
Finally, the [F_TEST] command tests whether a write lock can be
acquired on the specified region, without actually putting a lock.
- It returns immediately if successful, or fails otherwise. *)
+ It returns immediately if successful, or fails otherwise.
+
+ What happens when a process tries to lock a region of a file that is
+ already locked by the same process depends on the OS. On POSIX-compliant
+ systems, the second lock operation succeeds and may "promote" the older
+ lock from read lock to write lock. On Windows, the second lock
+ operation will block or fail.
+*)
(** {6 Signals}
val kill : int -> int -> unit
(** [kill pid sig] sends signal number [sig] to the process
- with id [pid]. On Windows, only the [Sys.sigkill] signal
+ with id [pid]. On Windows, only the {!Sys.sigkill} signal
is emulated. *)
type sigprocmask_command =
val gmtime : float -> tm
(** Convert a time in seconds, as returned by {!Unix.time}, into a date and
- a time. Assumes UTC (Coordinated Universal Time), also known as GMT. *)
+ a time. Assumes UTC (Coordinated Universal Time), also known as GMT.
+ To perform the inverse conversion, set the TZ environment variable
+ to "UTC", use {!mktime}, and then restore the original value of TZ. *)
val localtime : float -> tm
(** Convert a time in seconds, as returned by {!Unix.time}, into a date and
- a time. Assumes the local time zone. *)
+ a time. Assumes the local time zone.
+ The function performing the inverse conversion is {!mktime}. *)
val mktime : tm -> float * tm
(** Convert a date and time, specified by the [tm] argument, into
domain; [addr] is the Internet address of the machine, and
[port] is the port number. *)
-val socket : socket_domain -> socket_type -> int -> file_descr
+val socket :
+ ?cloexec:bool -> socket_domain -> socket_type -> int -> file_descr
(** Create a new socket in the given domain, and with the
given kind. The third argument is the protocol type; 0 selects
- the default protocol for that kind of sockets. *)
+ the default protocol for that kind of sockets.
+ See {!set_close_on_exec} for documentation on the [cloexec]
+ optional argument. *)
val domain_of_sockaddr: sockaddr -> socket_domain
(** Return the socket domain adequate for the given socket address. *)
val socketpair :
- socket_domain -> socket_type -> int -> file_descr * file_descr
-(** Create a pair of unnamed sockets, connected together. *)
+ ?cloexec:bool -> socket_domain -> socket_type -> int ->
+ file_descr * file_descr
+(** Create a pair of unnamed sockets, connected together.
+ See {!set_close_on_exec} for documentation on the [cloexec]
+ optional argument. *)
-val accept : file_descr -> file_descr * sockaddr
+val accept : ?cloexec:bool -> file_descr -> file_descr * sockaddr
(** Accept connections on the given socket. The returned descriptor
is a socket connected to the client; the returned address is
- the address of the connecting client. *)
+ the address of the connecting client.
+ See {!set_close_on_exec} for documentation on the [cloexec]
+ optional argument. *)
val bind : file_descr -> sockaddr -> unit
(** Bind a socket to an address. *)
val send_substring : file_descr -> string -> int -> int -> msg_flag list -> int
(** Same as [send], but take the data from a string instead of a byte
- sequence. *)
+ sequence.
+ @since 4.02.0 *)
val sendto :
file_descr -> bytes -> int -> int -> msg_flag list -> sockaddr -> int
val sendto_substring :
file_descr -> string -> int -> int -> msg_flag list -> sockaddr -> int
(** Same as [sendto], but take the data from a string instead of a
- byte sequence. *)
+ byte sequence.
+ @since 4.02.0 *)
(** {6 Socket options} *)
environment. Raise [Not_found] if the variable is unbound.
(This function is identical to [Sys.getenv].) *)
+(*
+val unsafe_getenv : string -> string
+(** Return the value associated to a variable in the process
+ environment.
+
+ Unlike {!getenv}, this function returns the value even if the
+ process has special privileges. It is considered unsafe because the
+ programmer of a setuid or setgid program must be careful to avoid
+ using maliciously crafted environment variables in the search path
+ for executables, the locations for temporary files or logs, and the
+ like.
+
+ @raise Not_found if the variable is unbound. *)
+*)
+
val putenv : string -> string -> unit
(** [Unix.putenv name value] sets the value associated to a
variable in the process environment.
while still open *)
| O_CLOEXEC (** Set the close-on-exec flag on the
descriptor returned by {!openfile} *)
+ | O_KEEPEXEC (** Clear the close-on-exec flag.
+ This is currently the default. *)
(** The flags to {!UnixLabels.openfile}. *)
val write_substring : file_descr -> buf:string -> pos:int -> len:int -> int
(** Same as [write], but take the data from a string instead of a byte
- sequence. *)
+ sequence.
+ @since 4.02.0 *)
val single_write_substring :
file_descr -> buf:string -> pos:int -> len:int -> int
(** Same as [single_write], but take the data from a string instead of
- a byte sequence. *)
+ a byte sequence.
+ @since 4.02.0 *)
(** {6 Interfacing with the standard input/output library} *)
(** {6 Operations on file descriptors} *)
-val dup : file_descr -> file_descr
+val dup : ?cloexec:bool -> file_descr -> file_descr
(** Return a new file descriptor referencing the same file as
the given descriptor. *)
-val dup2 : src:file_descr -> dst:file_descr -> unit
+val dup2 : ?cloexec:bool -> src:file_descr -> dst:file_descr -> unit
(** [dup2 fd1 fd2] duplicates [fd1] to [fd2], closing [fd2] if already
opened. *)
(** {6 Pipes and redirections} *)
-val pipe : unit -> file_descr * file_descr
+val pipe : ?cloexec:bool -> unit -> file_descr * file_descr
(** Create a pipe. The first component of the result is opened
for reading, that's the exit to the pipe. The second component is
opened for writing, that's the entrance to the pipe. *)
(** Returns [true] if the user is able to create symbolic links. On Windows,
this indicates that the user not only has the SeCreateSymbolicLinkPrivilege
but is also running elevated, if necessary. On other platforms, this is
- simply indicates that the symlink system call is available. *)
+ simply indicates that the symlink system call is available.
+ @since 4.03.0 *)
val readlink : string -> string
(** Read the contents of a link. *)
[port] is the port number. *)
val socket :
- domain:socket_domain -> kind:socket_type -> protocol:int -> file_descr
+ ?cloexec:bool -> domain:socket_domain -> kind:socket_type -> protocol:int ->
+ file_descr
(** Create a new socket in the given domain, and with the
given kind. The third argument is the protocol type; 0 selects
the default protocol for that kind of sockets. *)
(** Return the socket domain adequate for the given socket address. *)
val socketpair :
- domain:socket_domain -> kind:socket_type -> protocol:int ->
+ ?cloexec:bool -> domain:socket_domain -> kind:socket_type -> protocol:int ->
file_descr * file_descr
(** Create a pair of unnamed sockets, connected together. *)
-val accept : file_descr -> file_descr * sockaddr
+val accept : ?cloexec:bool -> file_descr -> file_descr * sockaddr
(** Accept connections on the given socket. The returned descriptor
is a socket connected to the client; the returned address is
the address of the connecting client. *)
val send_substring :
file_descr -> buf:string -> pos:int -> len:int -> mode:msg_flag list -> int
(** Same as [send], but take the data from a string instead of a byte
- sequence. *)
+ sequence.
+ @since 4.02.0 *)
val sendto :
file_descr -> buf:bytes -> pos:int -> len:int -> mode:msg_flag list ->
(** Send data over an unconnected socket. *)
val sendto_substring :
- file_descr -> bug:string -> pos:int -> len:int -> mode:msg_flag list
+ file_descr -> buf:string -> pos:int -> len:int -> mode:msg_flag list
-> sockaddr -> int
(** Same as [sendto], but take the data from a string instead of a
- byte sequence. *)
+ byte sequence.
+ @since 4.02.0 *)
#include "unixsupport.h"
#include "cst2constr.h"
#include <errno.h>
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+#include <fcntl.h>
#ifndef E2BIG
#define E2BIG (-1)
errconstr =
cst_to_constr(errcode, error_table, sizeof(error_table)/sizeof(int), -1);
if (errconstr == Val_int(-1)) {
- err = alloc_small(1, 0);
+ err = caml_alloc_small(1, 0);
Field(err, 0) = Val_int(errcode);
} else {
err = errconstr;
value name = Val_unit, err = Val_unit, arg = Val_unit;
Begin_roots3 (name, err, arg);
- arg = cmdarg == Nothing ? copy_string("") : cmdarg;
- name = copy_string(cmdname);
+ arg = cmdarg == Nothing ? caml_copy_string("") : cmdarg;
+ name = caml_copy_string(cmdname);
err = unix_error_of_code (errcode);
if (unix_error_exn == NULL) {
unix_error_exn = caml_named_value("Unix.Unix_error");
if (unix_error_exn == NULL)
- invalid_argument("Exception Unix.Unix_error not initialized,"
+ caml_invalid_argument("Exception Unix.Unix_error not initialized,"
" please link unix.cma");
}
- res = alloc_small(4, 0);
+ res = caml_alloc_small(4, 0);
Field(res, 0) = *unix_error_exn;
Field(res, 1) = err;
Field(res, 2) = name;
Field(res, 3) = arg;
End_roots();
- mlraise(res);
+ caml_raise(res);
}
void uerror(char *cmdname, value cmdarg)
{
if (! caml_string_is_c_safe(path)) unix_error(ENOENT, cmdname, path);
}
+
+int unix_cloexec_default = 0;
+
+int unix_cloexec_p(value cloexec)
+{
+ /* [cloexec] is a [bool option]. */
+ if (Is_block(cloexec))
+ return Bool_val(Field(cloexec, 0));
+ else
+ return unix_cloexec_default;
+}
+
+void unix_set_cloexec(int fd, char *cmdname, value cmdarg)
+{
+ int flags = fcntl(fd, F_GETFD, 0);
+ if (flags == -1 ||
+ fcntl(fd, F_SETFD, flags | FD_CLOEXEC) == -1)
+ uerror(cmdname, cmdarg);
+}
+
+void unix_clear_cloexec(int fd, char *cmdname, value cmdarg)
+{
+ int flags = fcntl(fd, F_GETFD, 0);
+ if (flags == -1 ||
+ fcntl(fd, F_SETFD, flags & ~FD_CLOEXEC) == -1)
+ uerror(cmdname, cmdarg);
+}
extern char ** cstringvect(value arg, char * cmdname);
+extern int unix_cloexec_default;
+extern int unix_cloexec_p(value cloexec);
+extern void unix_set_cloexec(int fd, char * cmdname, value arg);
+extern void unix_clear_cloexec(int fd, char * cmdname, value arg);
+
#ifdef __cplusplus
}
#endif
#else
CAMLprim value unix_utimes(value path, value atime, value mtime)
-{ invalid_argument("utimes not implemented"); }
+{ caml_invalid_argument("utimes not implemented"); }
#endif
value st, res;
if (WIFEXITED(status)) {
- st = alloc_small(1, TAG_WEXITED);
+ st = caml_alloc_small(1, TAG_WEXITED);
Field(st, 0) = Val_int(WEXITSTATUS(status));
}
else if (WIFSTOPPED(status)) {
- st = alloc_small(1, TAG_WSTOPPED);
+ st = caml_alloc_small(1, TAG_WSTOPPED);
Field(st, 0) = Val_int(caml_rev_convert_signal_number(WSTOPSIG(status)));
}
else {
- st = alloc_small(1, TAG_WSIGNALED);
+ st = caml_alloc_small(1, TAG_WSIGNALED);
Field(st, 0) = Val_int(caml_rev_convert_signal_number(WTERMSIG(status)));
}
Begin_root (st);
- res = alloc_small(2, 0);
+ res = caml_alloc_small(2, 0);
Field(res, 0) = Val_int(pid);
Field(res, 1) = st;
End_roots();
{
int pid, status;
- enter_blocking_section();
+ caml_enter_blocking_section();
pid = wait(&status);
- leave_blocking_section();
+ caml_leave_blocking_section();
if (pid == -1) uerror("wait", Nothing);
return alloc_process_status(pid, status);
}
{
int pid, status, cv_flags;
- cv_flags = convert_flag_list(flags, wait_flag_table);
- enter_blocking_section();
+ cv_flags = caml_convert_flag_list(flags, wait_flag_table);
+ caml_enter_blocking_section();
pid = waitpid(Int_val(pid_req), &status, cv_flags);
- leave_blocking_section();
+ caml_leave_blocking_section();
if (pid == -1) uerror("waitpid", Nothing);
return alloc_process_status(pid, status);
}
#else
CAMLprim value unix_waitpid(value flags, value pid_req)
-{ invalid_argument("waitpid not implemented"); }
+{ caml_invalid_argument("waitpid not implemented"); }
#endif
while (len > 0) {
numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len;
memmove (iobuf, &Byte(buf, ofs), numbytes);
- enter_blocking_section();
+ caml_enter_blocking_section();
ret = write(Int_val(fd), iobuf, numbytes);
- leave_blocking_section();
+ caml_leave_blocking_section();
if (ret == -1) {
if ((errno == EAGAIN || errno == EWOULDBLOCK) && written > 0) break;
uerror("write", Nothing);
if (len > 0) {
numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len;
memmove (iobuf, &Byte(buf, ofs), numbytes);
- enter_blocking_section();
+ caml_enter_blocking_section();
ret = write(Int_val(fd), iobuf, numbytes);
- leave_blocking_section();
+ caml_leave_blocking_section();
if (ret == -1) uerror("single_write", Nothing);
}
End_roots();
--- /dev/null
+#**************************************************************************
+#* *
+#* OCaml *
+#* *
+#* Xavier Leroy, projet Cristal, INRIA Rocquencourt *
+#* *
+#* Copyright 2001 Institut National de Recherche en Informatique et *
+#* en Automatique. *
+#* *
+#* All rights reserved. This file is distributed under the terms of *
+#* the GNU Lesser General Public License version 2.1, with the *
+#* special exception on linking described in the file LICENSE. *
+#* *
+#**************************************************************************
+
+LIBNAME=graphics
+COBJS=open.$(O) draw.$(O) events.$(O)
+CAMLOBJS=graphics.cmo
+WIN32LIBS=$(call SYSLIB,kernel32) $(call SYSLIB,gdi32) $(call SYSLIB,user32)
+LINKOPTS=-cclib "\"$(WIN32LIBS)\""
+LDOPTS=-ldopt "$(WIN32LIBS)"
+
+include ../Makefile
+
+graphics.ml: ../graph/graphics.ml
+ cp ../graph/graphics.ml graphics.ml
+graphics.mli: ../graph/graphics.mli
+ cp ../graph/graphics.mli graphics.mli
+
+depend:
+
+graphics.cmo: graphics.cmi
+graphics.cmx: graphics.cmi
+draw.$(O): libgraph.h
+open.$(O): libgraph.h
+
+clean:: partialclean
+ rm -f graphics.ml graphics.mli
#* *
#**************************************************************************
-LIBNAME=graphics
-COBJS=open.$(O) draw.$(O) events.$(O) dib.$(O)
-CAMLOBJS=graphics.cmo
-WIN32LIBS=$(call SYSLIB,kernel32) $(call SYSLIB,gdi32) $(call SYSLIB,user32)
-LINKOPTS=-cclib "\"$(WIN32LIBS)\""
-LDOPTS=-ldopt "$(WIN32LIBS)"
-
-include ../Makefile
-
-graphics.ml: ../graph/graphics.ml
- cp ../graph/graphics.ml graphics.ml
-graphics.mli: ../graph/graphics.mli
- cp ../graph/graphics.mli graphics.mli
-
-depend:
-
-graphics.cmo: graphics.cmi
-graphics.cmx: graphics.cmi
-draw.$(O): libgraph.h
-open.$(O): libgraph.h
-
-clean:: partialclean
- rm -f graphics.ml graphics.mli
+include Makefile
+++ /dev/null
-/**************************************************************************/
-/* */
-/* OCaml */
-/* */
-/* Developed by Jacob Navia */
-/* */
-/* 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. */
-/* */
-/**************************************************************************/
-
-//-----------------------------------------------------------------------------
-// DIB.C
-//
-// This is a collection of useful DIB manipulation/information gathering
-// functions. Many functions are supplied simply to take the burden
-// of taking into account whether a DIB is a Win30 style or OS/2 style
-// DIB away from the application.
-//
-// The functions in this module assume that the DIB pointers or handles
-// passed to them point to a block of memory in one of two formats:
-//
-// a) BITMAPINFOHEADER + color table + DIB bits (3.0 style DIB)
-// b) BITMAPCOREHEADER + color table + DIB bits (OS/2 PM style)
-//
-// The SDK Reference, Volume 2 describes these data structures.
-//
-// A number of functions in this module were lifted from SHOWDIB,
-// and modified to handle OS/2 DIBs.
-//
-// The functions in this module could be streamlined (made faster and
-// smaller) by removing the OS/2 DIB specific code, and assuming all
-// DIBs passed to it are Win30 style DIBs. The DIB file reading code
-// would need to be modified to always convert DIBs to Win30 style
-// DIBs. The only reason this isn't done in DIBView is because DIBView
-// was written to test display and printer drivers (which are supposed
-// to support OS/2 DIBs wherever they support Win30 style DIBs). SHOWDIB
-// is a great example of how to go about doing this.
-//-----------------------------------------------------------------------------
-
-
-#include <windows.h>
-#include <caml/memory.h>
-#include <string.h>
-#include <caml/io.h>
-#include <stdio.h>
- // Size of window extra bytes (we store a handle to a PALINFO structure).
-
-#define PAL_CBWNDEXTRA (1 * sizeof (WORD))
-
-
-typedef struct
- {
- HPALETTE hPal; // Handle to palette being displayed.
- WORD wEntries; // # of entries in the palette.
- int nSquareSize; // Size of palette square (see PAL_SIZE)
- HWND hInfoWnd; // Handle to the info bar window.
- int nRows, nCols; // # of Rows/Columns in window.
- int cxSquare, cySquare; // Pixel width/height of palette square.
- WORD wEntry; // Currently selected palette square.
- } PALINFO, FAR *LPPALINFO;
- // Window Words.
-#define WW_PAL_HPALINFO 0 // Handle to PALINFO structure.
- // The following define is for CopyPaletteChangingFlags().
-#define DONT_CHANGE_FLAGS -1
- // The following is the palette version that goes in a
- // LOGPALETTE's palVersion field.
-#define PALVERSION 0x300
-// This is an enumeration for the various ways we can display
-// a palette in PaletteWndProc().
-enum PAL_SIZE
- {
- PALSIZE_TINY = 0,
- PALSIZE_SMALL,
- PALSIZE_MEDIUM,
- PALSIZE_LARGE
- };
-#define CopyPalette(hPal) CopyPaletteChangingFlags (hPal, DONT_CHANGE_FLAGS)
-#define CopyPalForAnimation(hPal) CopyPaletteChangingFlags (hPal, PC_RESERVED)
-// WIDTHBYTES takes # of bits in a scan line and rounds up to nearest
-// word.
-#define WIDTHBYTES(bits) (((bits) + 31) / 32 * 4)
-
- // Given a pointer to a DIB header, return TRUE if is a Windows 3.0 style
- // DIB, false if otherwise (PM style DIB).
-#define IS_WIN30_DIB(lpbi) ((*(LPDWORD) (lpbi)) == sizeof (BITMAPINFOHEADER))
-
-static WORD PaletteSize (LPSTR lpbi);
-
-extern void ShowDbgMsg(char *);
-static BOOL MyRead (int, LPSTR, DWORD);
-/*-------------- DIB header Marker Define -------------------------*/
-#define DIB_HEADER_MARKER ((WORD) ('M' << 8) | 'B')
-/*-------------- MyRead Function Define ---------------------------*/
-
-// When we read in a DIB, we read it in in chunks. We read half a segment
-// at a time. This way we insure that we don't cross any segment
-// boundries in _lread() during a read. We don't read in a full segment
-// at a time, since _lread takes some "int" type parms instead of
-// WORD type params (it'd work, but the compiler would give you warnings)...
-
-#define BYTES_PER_READ 32767
-
-/*-------------- Define for PM DIB -------------------------------*/
-// The constants for RGB, RLE4, RLE8 are already defined inside
-// of Windows.h
-
-#define BI_PM 3L
-
-
-/*-------------- Magic numbers -------------------------------------*/
-// Maximum length of a filename for DOS is 128 characters.
-
-#define MAX_FILENAME 129
-
-
-/*-------------- TypeDef Structures -------------------------------*/
-
-typedef struct InfoStruct
- {
- char szName[13];
- char szType[15];
- DWORD cbWidth;
- DWORD cbHeight;
- DWORD cbColors;
- char szCompress[5];
- } INFOSTRUCT;
-
-// Some macros.
-#define RECTWIDTH(lpRect) ((lpRect)->right - (lpRect)->left)
-#define RECTHEIGHT(lpRect) ((lpRect)->bottom - (lpRect)->top)
-//---------------------------------------------------------------------
-//
-// Function: FindDIBBits
-//
-// Purpose: Given a pointer to a DIB, returns a pointer to the
-// DIB's bitmap bits.
-//
-// Parms: lpbi == pointer to DIB header (either BITMAPINFOHEADER
-// or BITMAPCOREHEADER)
-//
-// History: Date Reason
-// 6/01/91 Created
-//
-//---------------------------------------------------------------------
-static LPSTR FindDIBBits (LPSTR lpbi)
-{
- return (lpbi + *(LPDWORD)lpbi + PaletteSize (lpbi));
-}
-
-
-//---------------------------------------------------------------------
-//
-// Function: DIBNumColors
-//
-// Purpose: Given a pointer to a DIB, returns a number of colors in
-// the DIB's color table.
-//
-// Parms: lpbi == pointer to DIB header (either BITMAPINFOHEADER
-// or BITMAPCOREHEADER)
-//
-// History: Date Reason
-// 6/01/91 Created
-//
-//---------------------------------------------------------------------
-static WORD DIBNumColors (LPSTR lpbi)
-{
- WORD wBitCount;
-
-
- // If this is a Windows style DIB, the number of colors in the
- // color table can be less than the number of bits per pixel
- // allows for (i.e. lpbi->biClrUsed can be set to some value).
- // If this is the case, return the appropriate value.
-
- if (IS_WIN30_DIB (lpbi))
- {
- DWORD dwClrUsed;
-
- dwClrUsed = ((LPBITMAPINFOHEADER) lpbi)->biClrUsed;
-
- if (dwClrUsed)
- return (WORD) dwClrUsed;
- }
-
-
- // Calculate the number of colors in the color table based on
- // the number of bits per pixel for the DIB.
-
- if (IS_WIN30_DIB (lpbi))
- wBitCount = ((LPBITMAPINFOHEADER) lpbi)->biBitCount;
- else
- wBitCount = ((LPBITMAPCOREHEADER) lpbi)->bcBitCount;
-
- switch (wBitCount)
- {
- case 1:
- return 2;
-
- case 4:
- return 16;
-
- case 8:
- return 256;
-
- default:
- return 0;
- }
-}
-
-//---------------------------------------------------------------------
-//
-// Function: PaletteSize
-//
-// Purpose: Given a pointer to a DIB, returns number of bytes
-// in the DIB's color table.
-//
-// Parms: lpbi == pointer to DIB header (either BITMAPINFOHEADER
-// or BITMAPCOREHEADER)
-//
-// History: Date Reason
-// 6/01/91 Created
-//
-//---------------------------------------------------------------------
-static WORD PaletteSize (LPSTR lpbi)
-{
- if (IS_WIN30_DIB (lpbi))
- return (DIBNumColors (lpbi) * sizeof (RGBQUAD));
- else
- return (DIBNumColors (lpbi) * sizeof (RGBTRIPLE));
-}
-
-//---------------------------------------------------------------------
-//
-// Function: DIBHeight
-//
-// Purpose: Given a pointer to a DIB, returns its height. Note
-// that it returns a DWORD (since a Win30 DIB can have
-// a DWORD in its height field), but under Win30, the
-// high order word isn't used!
-//
-// Parms: lpDIB == pointer to DIB header (either BITMAPINFOHEADER
-// or BITMAPCOREHEADER)
-//
-// History: Date Reason
-// 6/01/91 Created
-//
-//---------------------------------------------------------------------
-static DWORD DIBHeight (LPSTR lpDIB)
-{
- LPBITMAPINFOHEADER lpbmi;
- LPBITMAPCOREHEADER lpbmc;
-
- lpbmi = (LPBITMAPINFOHEADER) lpDIB;
- lpbmc = (LPBITMAPCOREHEADER) lpDIB;
-
- if (lpbmi->biSize == sizeof (BITMAPINFOHEADER))
- return lpbmi->biHeight;
- else
- return (DWORD) lpbmc->bcHeight;
-}
-
-/*************************************************************************
-
- Function: ReadDIBFile (int)
-
- Purpose: Reads in the specified DIB file into a global chunk of
- memory.
-
- Returns: A handle to a dib (hDIB) if successful.
- NULL if an error occurs.
-
- Comments: BITMAPFILEHEADER is stripped off of the DIB. Everything
- from the end of the BITMAPFILEHEADER structure on is
- returned in the global memory handle.
-
- History: Date Author Reason
-
- 6/1/91 Created
- 6/27/91 Removed PM bitmap conversion routines.
- 6/31/91 Removed logic which overallocated memory
- (to account for bad display drivers).
- 11/08/91 Again removed logic which overallocated
- memory (it had creeped back in!)
-
-*************************************************************************/
-static HANDLE ReadDIBFile (int hFile,int dwBitsSize)
-{
- BITMAPFILEHEADER bmfHeader;
- HANDLE hDIB;
- LPSTR pDIB;
-
-
-
- // Go read the DIB file header and check if it's valid.
-
- if ((_lread (hFile, (LPSTR) &bmfHeader, sizeof (bmfHeader))
- != sizeof (bmfHeader))
- || (bmfHeader.bfType != DIB_HEADER_MARKER))
- {
- // ShowDbgMsg("Not a DIB file!");
- return NULL;
- }
-
- // Allocate memory for DIB
-
- hDIB = GlobalAlloc (GMEM_SHARE|GMEM_MOVEABLE | GMEM_ZEROINIT,
- dwBitsSize - sizeof(BITMAPFILEHEADER));
-
- if (hDIB == 0)
- {
- // ShowDbgMsg("Couldn't allocate memory!");
- return NULL;
- }
-
- pDIB = GlobalLock (hDIB);
-
- // Go read the bits.
-
- if (!MyRead (hFile, pDIB, dwBitsSize - sizeof(BITMAPFILEHEADER)))
- {
- GlobalUnlock (hDIB);
- GlobalFree (hDIB);
- // ShowDbgMsg("Error reading file!");
- return NULL;
- }
-
-
- GlobalUnlock (hDIB);
- return hDIB;
-}
-
-/*************************************************************************
-
- Function: MyRead (int, LPSTR, DWORD)
-
- Purpose: Routine to read files greater than 64K in size.
-
- Returns: TRUE if successful.
- FALSE if an error occurs.
-
- Comments:
-
- History: Date Reason
-
- 6/1/91 Created
-
-*************************************************************************/
-static BOOL MyRead (int hFile, LPSTR lpBuffer, DWORD dwSize)
-{
- char *lpInBuf = (char *) lpBuffer;
- int nBytes;
-
-
- while (dwSize)
- {
- nBytes = (int) (dwSize > (DWORD) BYTES_PER_READ ? BYTES_PER_READ :
- LOWORD (dwSize));
-
- if (_lread (hFile, (LPSTR) lpInBuf, nBytes) != (WORD) nBytes)
- return FALSE;
-
- dwSize -= nBytes;
- lpInBuf += nBytes;
- }
-
- return TRUE;
-}
-
-//---------------------------------------------------------------------
-//
-// Function: DIBPaint
-//
-// Purpose: Painting routine for a DIB. Calls StretchDIBits() or
-// SetDIBitsToDevice() to paint the DIB. The DIB is
-// output to the specified DC, at the coordinates given
-// in lpDCRect. The area of the DIB to be output is
-// given by lpDIBRect. The specified palette is used.
-//
-// Parms: hDC == DC to do output to.
-// lpDCRect == Rectangle on DC to do output to.
-// hDIB == Handle to global memory with a DIB spec
-// in it (either a BITMAPINFO or BITMAPCOREINFO
-// followed by the DIB bits).
-// lpDIBRect == Rect of DIB to output into lpDCRect.
-// hPal == Palette to be used.
-//
-// History: Date Reason
-// 6/01/91 Created
-//
-//---------------------------------------------------------------------
-static void DIBPaint (HDC hDC,LPRECT lpDCRect,HANDLE hDIB)
-{
- LPSTR lpDIBHdr, lpDIBBits;
-
- if (!hDIB)
- return;
- // Lock down the DIB, and get a pointer to the beginning of the bit
- // buffer.
- lpDIBHdr = GlobalLock (hDIB);
- lpDIBBits = FindDIBBits (lpDIBHdr);
- // Make sure to use the stretching mode best for color pictures.
- SetStretchBltMode (hDC, COLORONCOLOR);
- SetDIBitsToDevice (hDC, // hDC
- lpDCRect->left, // DestX
- lpDCRect->top, // DestY
- RECTWIDTH (lpDCRect), // nDestWidth
- RECTHEIGHT (lpDCRect), // nDestHeight
- 0, // SrcX
- 0,
- // (int) DIBHeight (lpDIBHdr), // SrcY
- 0, // nStartScan
- (WORD) DIBHeight (lpDIBHdr), // nNumScans
- lpDIBBits, // lpBits
- (LPBITMAPINFO) lpDIBHdr, // lpBitsInfo
- DIB_RGB_COLORS); // wUsage
-
- GlobalUnlock (hDIB);
-}
-
-static unsigned int Getfilesize(char *name)
-{
- FILE *f;
- unsigned int size;
-
- f = fopen(name,"rb");
- if (f == NULL)
- return 0;
- fseek(f,0,SEEK_END);
- size = ftell(f);
- fclose(f);
- return size;
-}
-
-
-HANDLE ChargerBitmap(char *FileName,POINT *lppt)
-{
- HFILE hFile;
- OFSTRUCT ofstruct;
- HANDLE result;
- LPSTR lpDIBHdr;
- unsigned int size;
-
- size = Getfilesize(FileName);
- hFile=OpenFile((LPSTR) FileName, &ofstruct,
- OF_READ | OF_SHARE_DENY_WRITE);
- result = ReadDIBFile(hFile,size);
- if (hFile) _lclose(hFile);
- if (result) {
- LPBITMAPINFOHEADER lpbmi;
- LPBITMAPCOREHEADER lpbmc;
-
- lpDIBHdr = GlobalLock (result);
- lpbmi = (LPBITMAPINFOHEADER) lpDIBHdr;
- lpbmc = (LPBITMAPCOREHEADER) lpDIBHdr;
-
- if (lpbmi->biSize == sizeof (BITMAPINFOHEADER)) {
- lppt->y = lpbmi->biHeight;
- lppt->x = lpbmi->biWidth;
- }
- else {
- lppt->y = lpbmc->bcHeight;
- lppt->x = lpbmc->bcWidth;
- }
- GlobalUnlock(result);
- }
- return(result);
-}
-
-void DessinerBitmap(HANDLE hDIB,HDC hDC,LPRECT lpDCRect)
-{
- DIBPaint (hDC,
- lpDCRect,
- hDIB);
-}
-
-void AfficheBitmap(char *filename,HDC hDC,int x,int y)
-{
- RECT rc;
- HANDLE hdib;
- POINT pt;
- char titi[60];
-
- hdib = ChargerBitmap(filename,&pt);
- if (hdib == NULL) {
- return;
- }
- rc.top = y;
- rc.left = x;
- rc.right = pt.x+x;
- rc.bottom = pt.y+y;
- pt.y += GetSystemMetrics(SM_CYCAPTION);
- DessinerBitmap(hdib,hDC,&rc);
- GlobalFree(hdib);
-}
argv[4], argv[5], FALSE);
}
-CAMLprim value caml_gr_draw_arc_nat(vx, vy, vrx, vry, vstart, vend)
+CAMLprim value caml_gr_draw_arc_nat(value vx, value vy, value vrx, value vry,
+ value vstart, value vend)
{
return gr_draw_or_fill_arc(vx, vy, vrx, vry, vstart, vend, FALSE);
}
r_x = Int_val(vrx);
r_y = Int_val(vry);
if ((r_x < 0) || (r_y < 0))
- invalid_argument("draw_arc: radius must be positive");
+ caml_invalid_argument("draw_arc: radius must be positive");
x = Int_val(vx);
y = Int_val(vy);
start = Int_val(vstart);
return Val_unit;
}
-CAMLprim value caml_gr_show_bitmap(value filename,int x,int y)
-{
- AfficheBitmap(filename,grwindow.gcBitmap,x,Wcvt(y));
- AfficheBitmap(filename,grwindow.gc,x,Wcvt(y));
- return Val_unit;
-}
-
-
-
CAMLprim value caml_gr_get_mousex(value unit)
{
POINT pt;
CAMLprim value caml_gr_draw_string(value str)
{
gr_check_open();
- caml_gr_draw_text(str, string_length(str));
+ caml_gr_draw_text(str, caml_string_length(str));
return Val_unit;
}
SIZE extent;
value res;
- mlsize_t len = string_length(str);
+ mlsize_t len = caml_string_length(str);
if (len > 32767) len = 32767;
GetTextExtentPoint(grwindow.gc,String_val(str), len,&extent);
- res = alloc_tuple(2);
+ res = caml_alloc_tuple(2);
Field(res, 0) = Val_long(extent.cx);
Field(res, 1) = Val_long(extent.cy);
argv[4], argv[5], TRUE);
}
-CAMLprim value caml_gr_fill_arc_nat(vx, vy, vrx, vry, vstart, vend)
+CAMLprim value caml_gr_fill_arc_nat(value vx, value vy, value vrx, value vry,
+ value vstart, value vend)
{
return gr_draw_or_fill_arc(vx, vy, vrx, vry, vstart, vend, TRUE);
}
cbm = CreateCompatibleBitmap(grwindow.gc, w, h);
if (cbm == NULL)
gr_fail("create_image: cannot create bitmap", 0);
- res = alloc_custom(&image_ops, sizeof(struct image),
+ res = caml_alloc_custom(&image_ops, sizeof(struct image),
w * h, Max_image_mem);
if (res) {
Width (res) = w;
if (size == 0) return Atom(0);
if (size <= Max_young_wosize) {
- res = alloc(size, 0);
+ res = caml_alloc(size, 0);
}
else {
- res = alloc_shr(size, 0);
+ res = caml_alloc_shr(size, 0);
}
for (i = 0; i < size; i++) {
Field(res, i) = Val_long(0);
Begin_roots2(img, matrix)
matrix = alloc_int_vect (height);
for (i = 0; i < height; i++) {
- modify (&Field (matrix, i), alloc_int_vect (width));
+ caml_modify (&Field (matrix, i), alloc_int_vect (width));
}
End_roots();
int button,
int keypressed, int key)
{
- value res = alloc_small(5, 0);
+ value res = caml_alloc_small(5, 0);
Field(res, 0) = Val_int(mouse_x);
Field(res, 1) = Val_int(grwindow.height - 1 - mouse_y);
Field(res, 2) = Val_bool(button);
CAMLprim value caml_gr_open_graph(value arg)
{
- long tid;
+ DWORD tid;
if (gr_initialized) return Val_unit;
open_graph_event = CreateEvent(NULL, FALSE, FALSE, NULL);
threadHandle =
if (graphic_failure_exn == NULL) {
graphic_failure_exn = caml_named_value("Graphics.Graphic_failure");
if (graphic_failure_exn == NULL)
- invalid_argument("Exception Graphics.Graphic_failure not initialized, "
+ caml_invalid_argument("Exception Graphics.Graphic_failure not initialized, "
"must link graphics.cma");
}
sprintf(buffer, fmt, arg);
- raise_with_string(*graphic_failure_exn, buffer);
+ caml_raise_with_string(*graphic_failure_exn, buffer);
}
void gr_check_open(void)
--- /dev/null
+#**************************************************************************
+#* *
+#* 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. *
+#* *
+#**************************************************************************
+
+# Note: since this directory is Windows-specific, it may be good to make sure
+# its content can not be compiled under Unix.
+# This directory could even become a subdirectory of the unix directory.
+
+# 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
+
+clean::
+ rm -f $(UNIX_FILES) $(UNIX_CAML_FILES)
+
+$(UNIX_FILES) $(UNIX_CAML_FILES): %: ../unix/%
+ cp ../unix/$* $*
+
+depend:
+
+$(COBJS): unixsupport.h
+
+include .depend
#* *
#**************************************************************************
-# 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
-
-clean::
- rm -f $(UNIX_FILES) $(UNIX_CAML_FILES)
-
-$(UNIX_FILES) $(UNIX_CAML_FILES): %: ../unix/%
- cp ../unix/$* $*
-
-depend:
-
-$(COBJS): unixsupport.h
-
-include .depend
+include Makefile
#include "unixsupport.h"
#include "socketaddr.h"
-CAMLprim value unix_accept(sock)
- value sock;
+CAMLprim value unix_accept(value cloexec, value sock)
{
SOCKET sconn = Socket_val(sock);
SOCKET snew;
DWORD err = 0;
addr_len = sizeof(sock_addr);
- enter_blocking_section();
+ caml_enter_blocking_section();
snew = accept(sconn, &addr.s_gen, &addr_len);
if (snew == INVALID_SOCKET) err = WSAGetLastError ();
- leave_blocking_section();
+ caml_leave_blocking_section();
if (snew == INVALID_SOCKET) {
win32_maperr(err);
uerror("accept", Nothing);
}
+ /* This is a best effort, not guaranteed to work, so don't fail on error */
+ SetHandleInformation((HANDLE) snew,
+ HANDLE_FLAG_INHERIT,
+ unix_cloexec_p(cloexec) ? 0 : HANDLE_FLAG_INHERIT);
Begin_roots2 (fd, adr)
fd = win_alloc_socket(snew);
adr = alloc_sockaddr(&addr, addr_len, snew);
- res = alloc_small(2, 0);
+ res = caml_alloc_small(2, 0);
Field(res, 0) = fd;
Field(res, 1) = adr;
End_roots();
#include <caml/memory.h>
#include "unixsupport.h"
#include <fcntl.h>
+#include <io.h>
#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);
-
int win_CRT_fd_of_filedescr(value handle)
{
if (CRT_fd_val(handle) != NO_CRT_FD) {
#include "unixsupport.h"
#include <caml/io.h>
-extern int _close(int);
-
CAMLprim value unix_close(value fd)
{
if (Descr_kind_val(fd) == KIND_SOCKET) {
DWORD err = 0;
get_sockaddr(address, &addr, &addr_len);
- enter_blocking_section();
+ caml_enter_blocking_section();
if (connect(s, &addr.s_gen, addr_len) == -1)
err = WSAGetLastError();
- leave_blocking_section();
+ caml_leave_blocking_section();
if (err) {
win32_maperr(err);
uerror("connect", Nothing);
/* */
/**************************************************************************/
+#define CAML_INTERNALS
+
#include <caml/mlvalues.h>
+#include <caml/memory.h>
#include "unixsupport.h"
#include <windows.h>
#include <caml/osdeps.h>
PROCESS_INFORMATION pi;
STARTUPINFO si;
char * exefile, * envp;
- int flags;
+ DWORD flags, err;
+ HANDLE hp;
caml_unix_check_path(cmd, "create_process");
if (! caml_string_is_c_safe(cmdline))
unix_error(EINVAL, "create_process", cmdline);
/* [env] is checked for null bytes at construction time, see unix.ml */
- exefile = search_exe_in_path(String_val(cmd));
+ err = ERROR_SUCCESS;
+ exefile = caml_search_exe_in_path(String_val(cmd));
if (env != Val_int(0)) {
envp = String_val(Field(env, 0));
} else {
ZeroMemory(&si, sizeof(STARTUPINFO));
si.cb = sizeof(STARTUPINFO);
si.dwFlags = STARTF_USESTDHANDLES;
- si.hStdInput = Handle_val(fd1);
- si.hStdOutput = Handle_val(fd2);
- si.hStdError = Handle_val(fd3);
+ /* Duplicate the handles fd1, fd2, fd3 to make sure they are inheritable */
+ hp = GetCurrentProcess();
+ if (! DuplicateHandle(hp, Handle_val(fd1), hp, &(si.hStdInput),
+ 0, TRUE, DUPLICATE_SAME_ACCESS)) {
+ err = GetLastError(); goto ret1;
+ }
+ if (! DuplicateHandle(hp, Handle_val(fd2), hp, &(si.hStdOutput),
+ 0, TRUE, DUPLICATE_SAME_ACCESS)) {
+ err = GetLastError(); goto ret2;
+ }
+ if (! DuplicateHandle(hp, Handle_val(fd3), hp, &(si.hStdError),
+ 0, TRUE, DUPLICATE_SAME_ACCESS)) {
+ err = GetLastError(); goto ret3;
+ }
/* If we do not have a console window, then we must create one
before running the process (keep it hidden for apparence).
If we are starting a GUI application, the newly created
/* Create the process */
if (! CreateProcess(exefile, String_val(cmdline), NULL, NULL,
TRUE, flags, envp, NULL, &si, &pi)) {
- caml_stat_free(exefile);
- win32_maperr(GetLastError());
- uerror("create_process", cmd);
+ err = GetLastError(); goto ret4;
}
- caml_stat_free(exefile);
CloseHandle(pi.hThread);
+ ret4:
+ CloseHandle(si.hStdError);
+ ret3:
+ CloseHandle(si.hStdOutput);
+ ret2:
+ CloseHandle(si.hStdInput);
+ ret1:
+ caml_stat_free(exefile);
+ if (err != ERROR_SUCCESS) {
+ win32_maperr(err);
+ uerror("create_process", cmd);
+ }
/* Return the process handle as pseudo-PID
(this is consistent with the wait() emulation in the MSVC C library */
return Val_long(pi.hProcess);
#include <caml/mlvalues.h>
#include "unixsupport.h"
-CAMLprim value unix_dup(value fd)
+CAMLprim value unix_dup(value cloexec, value fd)
{
HANDLE newh;
value newfd;
int kind = Descr_kind_val(fd);
if (! DuplicateHandle(GetCurrentProcess(), Handle_val(fd),
GetCurrentProcess(), &newh,
- 0L, TRUE, DUPLICATE_SAME_ACCESS)) {
+ 0L,
+ unix_cloexec_p(cloexec) ? FALSE : TRUE,
+ DUPLICATE_SAME_ACCESS)) {
win32_maperr(GetLastError());
return -1;
}
#include <caml/mlvalues.h>
#include "unixsupport.h"
-extern int _dup2(int, int);
-
-CAMLprim value unix_dup2(value fd1, value fd2)
+CAMLprim value unix_dup2(value cloexec, value fd1, value fd2)
{
HANDLE oldh, newh;
oldh = Handle_val(fd2);
if (! DuplicateHandle(GetCurrentProcess(), Handle_val(fd1),
GetCurrentProcess(), &newh,
- 0L, TRUE, DUPLICATE_SAME_ACCESS)) {
+ 0L,
+ unix_cloexec_p(cloexec) ? FALSE : TRUE,
+ DUPLICATE_SAME_ACCESS)) {
win32_maperr(GetLastError());
return -1;
}
errnum = Is_block(err) ? Int_val(Field(err, 0)) : error_table[Int_val(err)];
if (errnum > 0)
- return copy_string(strerror(errnum));
+ return caml_copy_string(strerror(errnum));
if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS,
NULL,
-errnum,
buffer,
sizeof(buffer),
NULL))
- return copy_string(buffer);
+ return caml_copy_string(buffer);
sprintf(buffer, "unknown error #%d", errnum);
- return copy_string(buffer);
+ return caml_copy_string(buffer);
}
#else
tm = *(uint64_t *)&ft - epoch_ft; /* shift to Epoch-relative time */
#endif
- return copy_double(tm * 1e-7); /* tm is in 100ns */
+ return caml_copy_double(tm * 1e-7); /* tm is in 100ns */
}
pCreateHardLink =
(tCreateHardLink) GetProcAddress(hModKernel32, "CreateHardLinkA");
if (pCreateHardLink == NULL)
- invalid_argument("Unix.link not implemented");
+ caml_invalid_argument("Unix.link not implemented");
caml_unix_check_path(path1, "link");
caml_unix_check_path(path2, "link");
if (! pCreateHardLink(String_val(path2), String_val(path1), NULL)) {
version.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
if(GetVersionEx(&version) == 0) {
- invalid_argument("lockf only supported on WIN32_NT platforms:"
+ caml_invalid_argument("lockf only supported on WIN32_NT platforms:"
" could not determine current platform.");
}
if(version.dwPlatformId != VER_PLATFORM_WIN32_NT) {
- invalid_argument("lockf only supported on WIN32_NT platforms");
+ caml_invalid_argument("lockf only supported on WIN32_NT platforms");
}
h = Handle_val(fd);
err = GetLastError();
break;
case 1: /* F_LOCK - blocking write lock */
- enter_blocking_section();
+ caml_enter_blocking_section();
if (! LockFileEx(h, LOCKFILE_EXCLUSIVE_LOCK, 0,
lock_len.LowPart, lock_len.HighPart, &overlap))
err = GetLastError();
- leave_blocking_section();
+ caml_leave_blocking_section();
break;
case 2: /* F_TLOCK - non-blocking write lock */
if (! LockFileEx(h, LOCKFILE_FAIL_IMMEDIATELY | LOCKFILE_EXCLUSIVE_LOCK, 0,
}
break;
case 4: /* F_RLOCK - blocking read lock */
- enter_blocking_section();
+ caml_enter_blocking_section();
if (! LockFileEx(h, 0, 0,
lock_len.LowPart, lock_len.HighPart, &overlap))
err = GetLastError();
- leave_blocking_section();
+ caml_leave_blocking_section();
break;
case 5: /* F_TRLOCK - non-blocking read lock */
if (! LockFileEx(h, LOCKFILE_FAIL_IMMEDIATELY, 0,
ret = caml_set_file_pointer(Handle_val(fd), Int64_val(ofs),
seek_command_table[Int_val(cmd)]);
- return copy_int64(ret);
+ return caml_copy_int64(ret);
}
#include "unixsupport.h"
#include <fcntl.h>
-static int open_access_flags[14] = {
+static int open_access_flags[15] = {
GENERIC_READ, GENERIC_WRITE, GENERIC_READ|GENERIC_WRITE,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
};
-static int open_create_flags[14] = {
- 0, 0, 0, 0, 0, O_CREAT, O_TRUNC, O_EXCL, 0, 0, 0, 0, 0, 0
+static int open_create_flags[15] = {
+ 0, 0, 0, 0, 0, O_CREAT, O_TRUNC, O_EXCL, 0, 0, 0, 0, 0, 0, 0
};
-static int open_share_flags[14] = {
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, FILE_SHARE_DELETE, 0
+static int open_share_flags[15] = {
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, FILE_SHARE_DELETE, 0, 0
};
-static int open_cloexec_flags[14] = {
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1
+enum { CLOEXEC = 1, KEEPEXEC = 2 };
+
+static int open_cloexec_flags[15] = {
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, CLOEXEC, KEEPEXEC
};
CAMLprim value unix_open(value path, value flags, value perm)
HANDLE h;
caml_unix_check_path(path, "open");
- fileaccess = convert_flag_list(flags, open_access_flags);
+ fileaccess = caml_convert_flag_list(flags, open_access_flags);
sharemode = FILE_SHARE_READ | FILE_SHARE_WRITE
- | convert_flag_list(flags, open_share_flags);
+ | caml_convert_flag_list(flags, open_share_flags);
- createflags = convert_flag_list(flags, open_create_flags);
+ createflags = caml_convert_flag_list(flags, open_create_flags);
if ((createflags & (O_CREAT | O_EXCL)) == (O_CREAT | O_EXCL))
filecreate = CREATE_NEW;
else if ((createflags & (O_CREAT | O_TRUNC)) == (O_CREAT | O_TRUNC))
else
fileattrib = FILE_ATTRIBUTE_NORMAL;
- cloexec = convert_flag_list(flags, open_cloexec_flags);
+ cloexec = caml_convert_flag_list(flags, open_cloexec_flags);
attr.nLength = sizeof(attr);
attr.lpSecurityDescriptor = NULL;
- attr.bInheritHandle = cloexec ? FALSE : TRUE;
+ attr.bInheritHandle =
+ cloexec & CLOEXEC ? FALSE
+ : cloexec & KEEPEXEC ? TRUE
+ : !unix_cloexec_default;
h = CreateFile(String_val(path), fileaccess,
sharemode, &attr,
/* PR#4749: pick a size that matches that of I/O buffers */
#define SIZEBUF 4096
-CAMLprim value unix_pipe(value unit)
+CAMLprim value unix_pipe(value cloexec, value unit)
{
SECURITY_ATTRIBUTES attr;
HANDLE readh, writeh;
attr.nLength = sizeof(attr);
attr.lpSecurityDescriptor = NULL;
- attr.bInheritHandle = TRUE;
+ attr.bInheritHandle = unix_cloexec_p(cloexec) ? FALSE : TRUE;
if (! CreatePipe(&readh, &writeh, &attr, SIZEBUF)) {
win32_maperr(GetLastError());
uerror("pipe", Nothing);
Begin_roots2(readfd, writefd)
readfd = win_alloc_handle(readh);
writefd = win_alloc_handle(writeh);
- res = alloc_small(2, 0);
+ res = caml_alloc_small(2, 0);
Field(res, 0) = readfd;
Field(res, 1) = writefd;
End_roots();
if (Descr_kind_val(fd) == KIND_SOCKET) {
int ret;
SOCKET s = Socket_val(fd);
- enter_blocking_section();
+ caml_enter_blocking_section();
ret = recv(s, iobuf, numbytes, 0);
if (ret == SOCKET_ERROR) err = WSAGetLastError();
- leave_blocking_section();
+ caml_leave_blocking_section();
numread = ret;
} else {
HANDLE h = Handle_val(fd);
- enter_blocking_section();
+ caml_enter_blocking_section();
if (! ReadFile(h, iobuf, numbytes, &numread, NULL))
err = GetLastError();
- leave_blocking_section();
+ caml_leave_blocking_section();
}
if (err) {
- win32_maperr(err);
- uerror("read", Nothing);
+ if (err == ERROR_BROKEN_PIPE) {
+ // The write handle for an anonymous pipe has been closed. We match the
+ // Unix behavior, and treat this as a zero-read instead of a Unix_error.
+ err = 0;
+ numread = 0;
+ } else {
+ win32_maperr(err);
+ uerror("read", Nothing);
+ }
}
memmove (&Byte(buf, Long_val(ofs)), iobuf, numread);
End_roots();
case SELECT_MODE_EXCEPT:
list = exceptfds;
break;
+ case SELECT_MODE_NONE:
+ CAMLassert(0);
};
for(i=0; list != Val_unit && i < iterResult->lpOrigIdx; ++i )
}
if (list == Val_unit)
- failwith ("select.c: original file handle not found");
+ caml_failwith ("select.c: original file handle not found");
result = Field(list, 0);
for (/*nothing*/; fdlist != Val_int(0); fdlist = Field(fdlist, 1)) {
value s = Field(fdlist, 0);
if (FD_ISSET(Socket_val(s), fdset)) {
- value newres = alloc_small(2, 0);
+ value newres = caml_alloc_small(2, 0);
Field(newres, 0) = s;
Field(newres, 1) = res;
res = newres;
&& exceptfds == Val_int(0)) {
DEBUG_PRINT("nothing to do");
if ( tm > 0.0 ) {
- enter_blocking_section();
+ caml_enter_blocking_section();
Sleep( (int)(tm * 1000));
- leave_blocking_section();
+ caml_leave_blocking_section();
}
read_list = write_list = except_list = Val_int(0);
} else {
tv.tv_usec = (int) (1e6 * (tm - (int) tm));
tvp = &tv;
}
- enter_blocking_section();
+ caml_enter_blocking_section();
if (select(FD_SETSIZE, &read, &write, &except, tvp) == -1) {
err = WSAGetLastError();
DEBUG_PRINT("Error %ld occurred", err);
}
- leave_blocking_section();
+ caml_leave_blocking_section();
if (err) {
DEBUG_PRINT("Error %ld occurred", err);
win32_maperr(err);
DEBUG_PRINT("Need to watch %d workers", nEventsCount);
/* Processing select itself */
- enter_blocking_section();
+ caml_enter_blocking_section();
/* There are worker started, waiting to be monitored */
if (nEventsCount > 0)
{
{
Sleep(milliseconds);
}
- leave_blocking_section();
+ caml_leave_blocking_section();
DEBUG_PRINT("Error status: %d (0 is ok)", err);
/* Build results */
for (i = 0; i < iterSelectData->nResultsCount; i++)
{
iterResult = &(iterSelectData->aResults[i]);
- l = alloc_small(2, 0);
+ l = caml_alloc_small(2, 0);
Store_field(l, 0, find_handle(iterResult, readfds, writefds,
exceptfds));
switch (iterResult->EMode)
Store_field(l, 1, except_list);
except_list = l;
break;
+ case SELECT_MODE_NONE:
+ CAMLassert(0);
}
}
/* We try to only process the first error, bypass other errors */
}
DEBUG_PRINT("Build final result");
- res = alloc_small(3, 0);
+ res = caml_alloc_small(3, 0);
Store_field(res, 0, read_list);
Store_field(res, 1, write_list);
Store_field(res, 2, except_list);
value flags)
{
SOCKET s = Socket_val(sock);
- int flg = convert_flag_list(flags, msg_flag_table);
+ int flg = caml_convert_flag_list(flags, msg_flag_table);
int ret;
intnat numbytes;
char iobuf[UNIX_BUFFER_SIZE];
Begin_root (buff);
numbytes = Long_val(len);
if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
- enter_blocking_section();
+ caml_enter_blocking_section();
ret = recv(s, iobuf, (int) numbytes, flg);
if (ret == -1) err = WSAGetLastError();
- leave_blocking_section();
+ caml_leave_blocking_section();
if (ret == -1) {
win32_maperr(err);
uerror("recv", Nothing);
value flags)
{
SOCKET s = Socket_val(sock);
- int flg = convert_flag_list(flags, msg_flag_table);
+ int flg = caml_convert_flag_list(flags, msg_flag_table);
int ret;
intnat numbytes;
char iobuf[UNIX_BUFFER_SIZE];
numbytes = Long_val(len);
if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
addr_len = sizeof(sock_addr);
- enter_blocking_section();
+ caml_enter_blocking_section();
ret = recvfrom(s, iobuf, (int) numbytes, flg, &addr.s_gen, &addr_len);
if (ret == -1) err = WSAGetLastError();
- leave_blocking_section();
+ caml_leave_blocking_section();
if (ret == -1) {
win32_maperr(err);
uerror("recvfrom", Nothing);
}
memmove (&Byte(buff, Long_val(ofs)), iobuf, ret);
adr = alloc_sockaddr(&addr, addr_len, -1);
- res = alloc_small(2, 0);
+ res = caml_alloc_small(2, 0);
Field(res, 0) = Val_int(ret);
Field(res, 1) = adr;
End_roots();
value flags)
{
SOCKET s = Socket_val(sock);
- int flg = convert_flag_list(flags, msg_flag_table);
+ int flg = caml_convert_flag_list(flags, msg_flag_table);
int ret;
intnat numbytes;
char iobuf[UNIX_BUFFER_SIZE];
numbytes = Long_val(len);
if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
memmove (iobuf, &Byte(buff, Long_val(ofs)), numbytes);
- enter_blocking_section();
+ caml_enter_blocking_section();
ret = send(s, iobuf, (int) numbytes, flg);
if (ret == -1) err = WSAGetLastError();
- leave_blocking_section();
+ caml_leave_blocking_section();
if (ret == -1) {
win32_maperr(err);
uerror("send", Nothing);
value flags, value dest)
{
SOCKET s = Socket_val(sock);
- int flg = convert_flag_list(flags, msg_flag_table);
+ int flg = caml_convert_flag_list(flags, msg_flag_table);
int ret;
intnat numbytes;
char iobuf[UNIX_BUFFER_SIZE];
numbytes = Long_val(len);
if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
memmove (iobuf, &Byte(buff, Long_val(ofs)), numbytes);
- enter_blocking_section();
+ caml_enter_blocking_section();
ret = sendto(s, iobuf, (int) numbytes, flg, &addr.s_gen, addr_len);
if (ret == -1) err = WSAGetLastError();
- leave_blocking_section();
+ caml_leave_blocking_section();
if (ret == -1) {
win32_maperr(err);
uerror("sendto", Nothing);
value t;
{
double d = Double_val(t);
- enter_blocking_section();
+ caml_enter_blocking_section();
Sleep(d * 1e3);
- leave_blocking_section();
+ caml_leave_blocking_section();
return Val_unit;
}
SOCK_STREAM, SOCK_DGRAM, SOCK_RAW, SOCK_SEQPACKET
};
-CAMLprim value unix_socket(domain, type, proto)
- value domain, type, proto;
+CAMLprim value unix_socket(value cloexec, value domain, value type, value proto)
{
SOCKET s;
win32_maperr(WSAGetLastError());
uerror("socket", Nothing);
}
+ /* This is a best effort, not guaranteed to work, so don't fail on error */
+ SetHandleInformation((HANDLE) s,
+ HANDLE_FLAG_INHERIT,
+ unix_cloexec_p(cloexec) ? 0 : HANDLE_FLAG_INHERIT);
return win_alloc_socket(s);
}
if (optval.lg.l_onoff == 0) {
return Val_int(0); /* None */
} else {
- value res = alloc_small(1, 0); /* Some */
+ value res = caml_alloc_small(1, 0); /* Some */
Field(res, 0) = Val_int(optval.lg.l_linger);
return res;
}
case TYPE_TIMEVAL:
- return copy_double((double) optval.tv.tv_sec
+ return caml_copy_double((double) optval.tv.tv_sec
+ (double) optval.tv.tv_usec / 1e6);
case TYPE_UNIX_ERROR:
if (optval.i == 0) {
value err, res;
err = unix_error_of_code(optval.i);
Begin_root(err);
- res = alloc_small(1, 0); /* Some */
+ res = caml_alloc_small(1, 0); /* Some */
Field(res, 0) = err;
End_roots();
return res;
Store_field (v, 6, Val_int (buf->st_gid));
Store_field (v, 7, Val_int (buf->st_rdev));
Store_field (v, 8,
- use_64 ? copy_int64(buf->st_size) : Val_int (buf->st_size));
- Store_field (v, 9, copy_double((double) buf->st_atime));
- Store_field (v, 10, copy_double((double) buf->st_mtime));
- Store_field (v, 11, copy_double((double) buf->st_ctime));
+ use_64 ? caml_copy_int64(buf->st_size) : Val_int (buf->st_size));
+ Store_field (v, 9, caml_copy_double((double) buf->st_atime / 10000000.0));
+ Store_field (v, 10, caml_copy_double((double) buf->st_mtime / 10000000.0));
+ Store_field (v, 11, caml_copy_double((double) buf->st_ctime / 10000000.0));
CAMLreturn (v);
}
static int convert_time(FILETIME* time, __time64_t* result, __time64_t def)
{
- SYSTEMTIME sys;
- FILETIME local;
+ /* Tempting though it may be, MSDN prohibits casting FILETIME directly
+ * to __int64 for alignment concerns. While this doesn't affect our supported
+ * platforms, it's easier to go with the flow...
+ */
+ ULARGE_INTEGER utime = {{time->dwLowDateTime, time->dwHighDateTime}};
- if (time->dwLowDateTime || time->dwHighDateTime) {
- if (!FileTimeToLocalFileTime(time, &local) ||
- !FileTimeToSystemTime(&local, &sys))
- {
- win32_maperr(GetLastError());
- return 0;
- }
- else
- {
- struct tm stamp = {sys.wSecond, sys.wMinute, sys.wHour,
- sys.wDay, sys.wMonth - 1, sys.wYear - 1900,
- 0, 0, 0};
- *result = _mktime64(&stamp);
- }
+ if (utime.QuadPart) {
+ /* There are 11644473600000 seconds between 1 January 1601 (the NT Epoch)
+ * and 1 January 1970 (the Unix Epoch). FILETIME is measured in 100ns ticks.
+ */
+ *result = (utime.QuadPart - INT64_LITERAL(116444736000000000U));
}
else {
*result = def;
/*
* Windows Vista functions enabled
*/
+#undef _WIN32_WINNT
#define _WIN32_WINNT 0x0600
#include <caml/mlvalues.h>
again:
if (no_symlink) {
- invalid_argument("symlink not available");
+ caml_invalid_argument("symlink not available");
}
if (!pCreateSymbolicLink) {
len = caml_string_length (cmd);
buf = caml_stat_alloc (len + 1);
memmove (buf, String_val (cmd), len + 1);
- enter_blocking_section();
+ caml_enter_blocking_section();
_flushall();
ret = system(buf);
- leave_blocking_section();
+ caml_leave_blocking_section();
caml_stat_free(buf);
if (ret == -1) uerror("system", Nothing);
- st = alloc_small(1, 0); /* Tag 0: Exited */
+ st = caml_alloc_small(1, 0); /* Tag 0: Exited */
Field(st, 0) = Val_int(ret);
return st;
}
uerror("times", Nothing);
}
- res = alloc_small(4 * Double_wosize, Double_array_tag);
+ res = caml_alloc_small(4 * Double_wosize, Double_array_tag);
Store_double_field(res, 0, to_sec(utime));
Store_double_field(res, 1, to_sec(stime));
Store_double_field(res, 2, 0);
external environment : unit -> string array = "unix_environment"
external getenv: string -> string = "caml_sys_getenv"
+(* external unsafe_getenv: string -> string = "caml_sys_unsafe_getenv" *)
external putenv: string -> string -> unit = "unix_putenv"
type process_status =
| O_RSYNC
| O_SHARE_DELETE
| O_CLOEXEC
+ | O_KEEPEXEC
type file_perm = int
(* Operations on file descriptors *)
-external dup : file_descr -> file_descr = "unix_dup"
-external dup2 : file_descr -> file_descr -> unit = "unix_dup2"
+external dup : ?cloexec: bool -> file_descr -> file_descr = "unix_dup"
+external dup2 :
+ ?cloexec: bool -> file_descr -> file_descr -> unit = "unix_dup2"
external set_nonblock : file_descr -> unit = "unix_set_nonblock"
external clear_nonblock : file_descr -> unit = "unix_clear_nonblock"
(* Pipes *)
-external pipe : unit -> file_descr * file_descr = "unix_pipe"
+external pipe :
+ ?cloexec: bool -> unit -> file_descr * file_descr = "unix_pipe"
let mkfifo _name _perm = invalid_arg "Unix.mkfifo not implemented"
| MSG_DONTROUTE
| MSG_PEEK
-external socket : socket_domain -> socket_type -> int -> file_descr
- = "unix_socket"
-let socketpair _dom _ty _proto = invalid_arg "Unix.socketpair not implemented"
-external accept : file_descr -> file_descr * sockaddr = "unix_accept"
+external socket :
+ ?cloexec: bool -> socket_domain -> socket_type -> int -> file_descr
+ = "unix_socket"
+let socketpair ?cloexec:_ _dom _ty _proto = invalid_arg "Unix.socketpair not implemented"
+external accept :
+ ?cloexec: bool -> file_descr -> file_descr * sockaddr = "unix_accept"
external bind : file_descr -> sockaddr -> unit = "unix_bind"
external connect : file_descr -> sockaddr -> unit = "unix_connect"
external listen : file_descr -> int -> unit = "unix_listen"
let make_cmdline args =
let maybe_quote f =
- if String.contains f ' ' || String.contains f '\"' || f = ""
+ if String.contains f ' ' ||
+ String.contains f '\"' ||
+ String.contains f '\t' ||
+ f = ""
then Filename.quote f
else f in
String.concat " " (List.map maybe_quote (Array.to_list args))
Hashtbl.add popen_processes proc pid
let open_process_in cmd =
- let (in_read, in_write) = pipe() in
- set_close_on_exec in_read;
+ let (in_read, in_write) = pipe ~cloexec:true () in
let inchan = in_channel_of_descr in_read in
- open_proc cmd None (Process_in inchan) stdin in_write stderr;
+ begin
+ try
+ open_proc cmd None (Process_in inchan) stdin in_write stderr
+ with e ->
+ close_in inchan;
+ close in_write;
+ raise e
+ end;
close in_write;
inchan
let open_process_out cmd =
- let (out_read, out_write) = pipe() in
- set_close_on_exec out_write;
+ let (out_read, out_write) = pipe ~cloexec:true () in
let outchan = out_channel_of_descr out_write in
- open_proc cmd None (Process_out outchan) out_read stdout stderr;
+ begin
+ try
+ open_proc cmd None (Process_out outchan) out_read stdout stderr
+ with e ->
+ close_out outchan;
+ close out_read;
+ raise e
+ end;
close out_read;
outchan
let open_process cmd =
- let (in_read, in_write) = pipe() in
- let (out_read, out_write) = pipe() in
- set_close_on_exec in_read;
- set_close_on_exec out_write;
+ let (in_read, in_write) = pipe ~cloexec:true () in
+ let (out_read, out_write) =
+ try pipe ~cloexec:true ()
+ with e -> close in_read; close in_write; raise e in
let inchan = in_channel_of_descr in_read in
let outchan = out_channel_of_descr out_write in
- open_proc cmd None (Process(inchan, outchan)) out_read in_write stderr;
- close out_read; close in_write;
+ begin
+ try
+ open_proc cmd None (Process(inchan, outchan)) out_read in_write stderr
+ with e ->
+ close out_read; close out_write;
+ close in_read; close in_write;
+ raise e
+ end;
+ close out_read;
+ close in_write;
(inchan, outchan)
let open_process_full cmd env =
- let (in_read, in_write) = pipe() in
- let (out_read, out_write) = pipe() in
- let (err_read, err_write) = pipe() in
- set_close_on_exec in_read;
- set_close_on_exec out_write;
- set_close_on_exec err_read;
+ let (in_read, in_write) = pipe ~cloexec:true () in
+ let (out_read, out_write) =
+ try pipe ~cloexec:true ()
+ with e -> close in_read; close in_write; raise e in
+ let (err_read, err_write) =
+ try pipe ~cloexec:true ()
+ with e -> close in_read; close in_write;
+ close out_read; close out_write; raise e in
let inchan = in_channel_of_descr in_read in
let outchan = out_channel_of_descr out_write in
let errchan = in_channel_of_descr err_read in
- open_proc cmd (Some(make_process_env env))
- (Process_full(inchan, outchan, errchan))
- out_read in_write err_write;
- close out_read; close in_write; close err_write;
+ begin
+ try
+ open_proc cmd (Some (make_process_env env))
+ (Process_full(inchan, outchan, errchan))
+ out_read in_write err_write
+ with e ->
+ close out_read; close out_write;
+ close in_read; close in_write;
+ close err_read; close err_write;
+ raise e
+ end;
+ close out_read;
+ close in_write;
+ close err_write;
(inchan, outchan, errchan)
let find_proc_id fun_name proc =
let open_connection sockaddr =
let sock =
- socket (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
+ socket ~cloexec:true (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
try
connect sock sockaddr;
- set_close_on_exec sock;
(in_channel_of_descr sock, out_channel_of_descr sock)
with exn ->
close sock; raise exn
value win_alloc_handle(HANDLE h)
{
- value res = alloc_custom(&win_handle_ops, sizeof(struct filedescr), 0, 1);
+ value res = caml_alloc_custom(&win_handle_ops, sizeof(struct filedescr), 0, 1);
Handle_val(res) = h;
Descr_kind_val(res) = KIND_HANDLE;
CRT_fd_val(res) = NO_CRT_FD;
value win_alloc_socket(SOCKET s)
{
- value res = alloc_custom(&win_handle_ops, sizeof(struct filedescr), 0, 1);
+ value res = caml_alloc_custom(&win_handle_ops, sizeof(struct filedescr), 0, 1);
Socket_val(res) = s;
Descr_kind_val(res) = KIND_SOCKET;
CRT_fd_val(res) = NO_CRT_FD;
errconstr =
cst_to_constr(errcode, error_table, sizeof(error_table)/sizeof(int), -1);
if (errconstr == Val_int(-1)) {
- err = alloc_small(1, 0);
+ err = caml_alloc_small(1, 0);
Field(err, 0) = Val_int(errcode);
} else {
err = errconstr;
int errconstr;
Begin_roots3 (name, err, arg);
- arg = cmdarg == Nothing ? copy_string("") : cmdarg;
- name = copy_string(cmdname);
+ arg = cmdarg == Nothing ? caml_copy_string("") : cmdarg;
+ name = caml_copy_string(cmdname);
err = unix_error_of_code (errcode);
if (unix_error_exn == NULL) {
unix_error_exn = caml_named_value("Unix.Unix_error");
if (unix_error_exn == NULL)
- invalid_argument("Exception Unix.Unix_error not initialized,"
+ caml_invalid_argument("Exception Unix.Unix_error not initialized,"
" please link unix.cma");
}
- res = alloc_small(4, 0);
+ res = caml_alloc_small(4, 0);
Field(res, 0) = *unix_error_exn;
Field(res, 1) = err;
Field(res, 2) = name;
Field(res, 3) = arg;
End_roots();
- mlraise(res);
+ caml_raise(res);
}
void uerror(char * cmdname, value cmdarg)
{
if (! caml_string_is_c_safe(path)) unix_error(ENOENT, cmdname, path);
}
+
+int unix_cloexec_default = 0;
+
+int unix_cloexec_p(value cloexec)
+{
+ /* [cloexec] is a [bool option]. */
+ if (Is_block(cloexec))
+ return Bool_val(Field(cloexec, 0));
+ else
+ return unix_cloexec_default;
+}
extern void win32_maperr(DWORD errcode);
extern value unix_error_of_code (int errcode);
-extern void unix_error (int errcode, char * cmdname, value arg);
-extern void uerror (char * cmdname, value arg);
+
+CAMLnoreturn_start
+extern void unix_error (int errcode, char * cmdname, value arg)
+CAMLnoreturn_end;
+
+CAMLnoreturn_start
+extern void uerror (char * cmdname, value arg)
+CAMLnoreturn_end;
+
extern void caml_unix_check_path(value path, char * cmdname);
extern value unix_freeze_buffer (value);
extern char ** cstringvect(value arg, char * cmdname);
+extern int unix_cloexec_default;
+extern int unix_cloexec_p(value cloexec);
+
/* Information stored in flags_fd, describing more precisely the socket
* and its status. The whole flags_fd is initialized to 0.
*/
if (h == INVALID_HANDLE_VALUE) {
DWORD err = GetLastError();
if (err == ERROR_NO_MORE_FILES)
- raise_end_of_file();
+ caml_raise_end_of_file();
else {
win32_maperr(err);
uerror("opendir", Nothing);
}
}
- valname = copy_string(fileinfo.cFileName);
+ valname = caml_copy_string(fileinfo.cFileName);
valh = win_alloc_handle(h);
- v = alloc_small(2, 0);
+ v = caml_alloc_small(2, 0);
Field(v,0) = valname;
Field(v,1) = valh;
End_roots();
if (!retcode) {
DWORD err = GetLastError();
if (err == ERROR_NO_MORE_FILES)
- raise_end_of_file();
+ caml_raise_end_of_file();
else {
win32_maperr(err);
uerror("readdir", Nothing);
}
}
- return copy_string(fileinfo.cFileName);
+ return caml_copy_string(fileinfo.cFileName);
}
CAMLprim value win_findclose(value valh)
{
value res, st;
- st = alloc(1, 0);
+ st = caml_alloc(1, 0);
Field(st, 0) = Val_int(status);
Begin_root (st);
- res = alloc_small(2, 0);
+ res = caml_alloc_small(2, 0);
Field(res, 0) = Val_long((intnat) pid);
Field(res, 1) = st;
End_roots();
HANDLE pid_req = (HANDLE) Long_val(vpid_req);
DWORD err = 0;
- flags = convert_flag_list(vflags, wait_flag_table);
+ flags = caml_convert_flag_list(vflags, wait_flag_table);
if ((flags & CAML_WNOHANG) == 0) {
- enter_blocking_section();
+ caml_enter_blocking_section();
retcode = WaitForSingleObject(pid_req, INFINITE);
if (retcode == WAIT_FAILED) err = GetLastError();
- leave_blocking_section();
+ caml_leave_blocking_section();
if (err) {
win32_maperr(err);
uerror("waitpid", Nothing);
LPWORKER lpWorker = worker_pop();
DEBUG_PRINT("Waiting for worker to be ready");
- enter_blocking_section();
+ caml_enter_blocking_section();
WaitForSingleObject(lpWorker->hWorkerReady, INFINITE);
ResetEvent(lpWorker->hWorkerReady);
- leave_blocking_section();
+ caml_leave_blocking_section();
DEBUG_PRINT("Worker is ready");
lpWorker->hJobFunc = f;
void worker_job_finish (LPWORKER lpWorker)
{
DEBUG_PRINT("Finishing call of worker %x", lpWorker);
- enter_blocking_section();
+ caml_enter_blocking_section();
WaitForSingleObject(lpWorker->hJobDone, INFINITE);
- leave_blocking_section();
+ caml_leave_blocking_section();
worker_push(lpWorker);
}
#ifndef _WINWORKER_H
#define _WINWORKER_H
+#undef _WIN32_WINNT
#define _WIN32_WINNT 0x0400
#include "unixsupport.h"
#include <windows.h>
if (Descr_kind_val(fd) == KIND_SOCKET) {
int ret;
SOCKET s = Socket_val(fd);
- enter_blocking_section();
+ caml_enter_blocking_section();
ret = send(s, iobuf, numbytes, 0);
if (ret == SOCKET_ERROR) err = WSAGetLastError();
- leave_blocking_section();
+ caml_leave_blocking_section();
numwritten = ret;
} else {
HANDLE h = Handle_val(fd);
- enter_blocking_section();
+ caml_enter_blocking_section();
if (! WriteFile(h, iobuf, numbytes, &numwritten, NULL))
err = GetLastError();
- leave_blocking_section();
+ caml_leave_blocking_section();
}
if (err) {
win32_maperr(err);
if (Descr_kind_val(fd) == KIND_SOCKET) {
int ret;
SOCKET s = Socket_val(fd);
- enter_blocking_section();
+ caml_enter_blocking_section();
ret = send(s, iobuf, numbytes, 0);
if (ret == SOCKET_ERROR) err = WSAGetLastError();
- leave_blocking_section();
+ caml_leave_blocking_section();
numwritten = ret;
} else {
HANDLE h = Handle_val(fd);
- enter_blocking_section();
+ caml_enter_blocking_section();
if (! WriteFile(h, iobuf, numbytes, &numwritten, NULL))
err = GetLastError();
- leave_blocking_section();
+ caml_leave_blocking_section();
}
if (err) {
win32_maperr(err);
--- /dev/null
+link:parsetree.mli[Parsetree] and link:asttypes.mli[Asttypes]::
+Parsetree is an Abstract Syntax Tree (AST) representation of OCaml
+source code. It is well annotated with examples and is a recommended
+read before any further exploration of the compiler.
+
+link:location.mli[Location]:: This module contains utilities
+related to locations and error handling. In particular, it contains
+handlers that are used for all the error reporting in the compiler.
+
match t.ptyp_desc with
| Ptyp_poly _ -> t
| _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *)
+
+ let varify_constructors var_names t =
+ let check_variable vl loc v =
+ if List.mem v vl then
+ raise Syntaxerr.(Error(Variable_in_scope(loc,v))) in
+ let var_names = List.map (fun v -> v.txt) var_names in
+ let rec loop t =
+ let desc =
+ match t.ptyp_desc with
+ | Ptyp_any -> Ptyp_any
+ | Ptyp_var x ->
+ check_variable var_names t.ptyp_loc x;
+ Ptyp_var x
+ | Ptyp_arrow (label,core_type,core_type') ->
+ Ptyp_arrow(label, loop core_type, loop core_type')
+ | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst)
+ | Ptyp_constr( { txt = Longident.Lident s }, [])
+ when List.mem s var_names ->
+ Ptyp_var s
+ | Ptyp_constr(longident, lst) ->
+ Ptyp_constr(longident, List.map loop lst)
+ | Ptyp_object (lst, o) ->
+ Ptyp_object
+ (List.map (fun (s, attrs, t) -> (s, attrs, loop t)) lst, o)
+ | Ptyp_class (longident, lst) ->
+ Ptyp_class (longident, List.map loop lst)
+ | Ptyp_alias(core_type, string) ->
+ check_variable var_names t.ptyp_loc string;
+ Ptyp_alias(loop core_type, string)
+ | Ptyp_variant(row_field_list, flag, lbl_lst_option) ->
+ Ptyp_variant(List.map loop_row_field row_field_list,
+ flag, lbl_lst_option)
+ | Ptyp_poly(string_lst, core_type) ->
+ List.iter (fun v ->
+ check_variable var_names t.ptyp_loc v.txt) string_lst;
+ Ptyp_poly(string_lst, loop core_type)
+ | Ptyp_package(longident,lst) ->
+ Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst)
+ | Ptyp_extension (s, arg) ->
+ Ptyp_extension (s, arg)
+ in
+ {t with ptyp_desc = desc}
+ and loop_row_field =
+ function
+ | Rtag(label,attrs,flag,lst) ->
+ Rtag(label,attrs,flag,List.map loop lst)
+ | Rinherit t ->
+ Rinherit (loop t)
+ in
+ loop t
+
end
module Pat = struct
val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type
val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type
val object_: ?loc:loc -> ?attrs:attrs ->
- (string * attributes * core_type) list -> closed_flag ->
+ (str * attributes * core_type) list -> closed_flag ->
core_type
val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type
val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type
val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag
-> label list option -> core_type
- val poly: ?loc:loc -> ?attrs:attrs -> string list -> core_type -> core_type
+ val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type
val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list
-> core_type
val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type
val force_poly: core_type -> core_type
+
+ val varify_constructors: str list -> core_type -> core_type
+ (** [varify_constructors newtypes te] is type expression [te], of which
+ any of nullary type constructor [tc] is replaced by type variable of
+ the same name, if [tc]'s name appears in [newtypes].
+ Raise [Syntaxerr.Variable_in_scope] if any type variable inside [te]
+ appears in [newtypes].
+ @since 4.05
+ *)
end
(** Patterns *)
-> core_type -> expression
val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type
-> expression
- val send: ?loc:loc -> ?attrs:attrs -> expression -> string -> expression
+ val send: ?loc:loc -> ?attrs:attrs -> expression -> str -> expression
val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression
val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression
val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list
val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option
-> expression
val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression
- val newtype: ?loc:loc -> ?attrs:attrs -> string -> expression -> expression
+ val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression
val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression
val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> expression
-> expression
val attr: class_type_field -> attribute -> class_type_field
val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field
- val val_: ?loc:loc -> ?attrs:attrs -> string -> mutable_flag ->
+ val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag ->
virtual_flag -> core_type -> class_type_field
- val method_: ?loc:loc -> ?attrs:attrs -> string -> private_flag ->
+ val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag ->
virtual_flag -> core_type -> class_type_field
val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type ->
class_type_field
val attr: class_field -> attribute -> class_field
val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr ->
- string option -> class_field
+ str option -> class_field
val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag ->
class_field_kind -> class_field
val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag ->
| Ptyp_constr (lid, tl) ->
constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
| Ptyp_object (l, o) ->
- let f (s, a, t) = (s, sub.attributes sub a, sub.typ sub t) in
+ let f (s, a, t) =
+ (map_loc sub s, sub.attributes sub a, sub.typ sub t) in
object_ ~loc ~attrs (List.map f l) o
| Ptyp_class (lid, tl) ->
class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
| Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s
| Ptyp_variant (rl, b, ll) ->
variant ~loc ~attrs (List.map (row_field sub) rl) b ll
- | Ptyp_poly (sl, t) -> poly ~loc ~attrs sl (sub.typ sub t)
+ | Ptyp_poly (sl, t) -> poly ~loc ~attrs
+ (List.map (map_loc sub) sl) (sub.typ sub t)
| Ptyp_package (lid, l) ->
package ~loc ~attrs (map_loc sub lid)
(List.map (map_tuple (map_loc sub) (sub.typ sub)) l)
let attrs = sub.attributes sub attrs in
match desc with
| Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct)
- | Pctf_val (s, m, v, t) -> val_ ~loc ~attrs s m v (sub.typ sub t)
- | Pctf_method (s, p, v, t) -> method_ ~loc ~attrs s p v (sub.typ sub t)
+ | Pctf_val (s, m, v, t) ->
+ val_ ~loc ~attrs (map_loc sub s) m v (sub.typ sub t)
+ | Pctf_method (s, p, v, t) ->
+ method_ ~loc ~attrs (map_loc sub s) p v (sub.typ sub t)
| Pctf_constraint (t1, t2) ->
constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2)
| Pctf_attribute x -> attribute ~loc (sub.attribute sub x)
(sub.typ sub t2)
| Pexp_constraint (e, t) ->
constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t)
- | Pexp_send (e, s) -> send ~loc ~attrs (sub.expr sub e) s
+ | Pexp_send (e, s) ->
+ send ~loc ~attrs (sub.expr sub e) (map_loc sub s)
| Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid)
| Pexp_setinstvar (s, e) ->
setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e)
| Pexp_poly (e, t) ->
poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t)
| Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls)
- | Pexp_newtype (s, e) -> newtype ~loc ~attrs s (sub.expr sub e)
+ | Pexp_newtype (s, e) ->
+ newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e)
| Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me)
| Pexp_open (ovf, lid, e) ->
open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e)
let loc = sub.location sub loc in
let attrs = sub.attributes sub attrs in
match desc with
- | Pcf_inherit (o, ce, s) -> inherit_ ~loc ~attrs o (sub.class_expr sub ce) s
+ | Pcf_inherit (o, ce, s) ->
+ inherit_ ~loc ~attrs o (sub.class_expr sub ce)
+ (map_opt (map_loc sub) s)
| Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k)
| Pcf_method (s, p, k) ->
method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k)
calling it ["ocamlc"], ["ocamlopt"], ["ocamldoc"], ["ocamldep"],
["ocaml"], ... Some global variables that reflect command-line
options are automatically synchronized between the calling tool
- and the ppx preprocessor: [Clflags.include_dirs],
- [Config.load_path], [Clflags.open_modules], [Clflags.for_package],
- [Clflags.debug]. *)
+ and the ppx preprocessor: {!Clflags.include_dirs},
+ {!Config.load_path}, {!Clflags.open_modules}, {!Clflags.for_package},
+ {!Clflags.debug}. *)
val apply: source:string -> target:string -> mapper -> unit
val run_main: (string list -> mapper) -> unit
(** Entry point to call to implement a standalone -ppx rewriter from a
mapper, parametrized by the command line arguments. The current
- unit name can be obtained from [Location.input_name]. This
+ unit name can be obtained from {!Location.input_name}. This
function implements proper error reporting for uncaught
exceptions. *)
let pat_of_label lbl pos =
mkpat (Ppat_var (mkrhs (Longident.last lbl) pos))
-let check_variable vl loc v =
- if List.mem v vl then
- raise Syntaxerr.(Error(Variable_in_scope(loc,v)))
-
-let varify_constructors var_names t =
- let rec loop t =
- let desc =
- match t.ptyp_desc with
- | Ptyp_any -> Ptyp_any
- | Ptyp_var x ->
- check_variable var_names t.ptyp_loc x;
- Ptyp_var x
- | Ptyp_arrow (label,core_type,core_type') ->
- Ptyp_arrow(label, loop core_type, loop core_type')
- | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst)
- | Ptyp_constr( { txt = Lident s }, []) when List.mem s var_names ->
- Ptyp_var s
- | Ptyp_constr(longident, lst) ->
- Ptyp_constr(longident, List.map loop lst)
- | Ptyp_object (lst, o) ->
- Ptyp_object
- (List.map (fun (s, attrs, t) -> (s, attrs, loop t)) lst, o)
- | Ptyp_class (longident, lst) ->
- Ptyp_class (longident, List.map loop lst)
- | Ptyp_alias(core_type, string) ->
- check_variable var_names t.ptyp_loc string;
- Ptyp_alias(loop core_type, string)
- | Ptyp_variant(row_field_list, flag, lbl_lst_option) ->
- Ptyp_variant(List.map loop_row_field row_field_list,
- flag, lbl_lst_option)
- | Ptyp_poly(string_lst, core_type) ->
- List.iter (check_variable var_names t.ptyp_loc) string_lst;
- Ptyp_poly(string_lst, loop core_type)
- | Ptyp_package(longident,lst) ->
- Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst)
- | Ptyp_extension (s, arg) ->
- Ptyp_extension (s, arg)
- in
- {t with ptyp_desc = desc}
- and loop_row_field =
- function
- | Rtag(label,attrs,flag,lst) ->
- Rtag(label,attrs,flag,List.map loop lst)
- | Rinherit t ->
- Rinherit (loop t)
- in
- loop t
-
let mk_newtypes newtypes exp =
List.fold_right (fun newtype exp -> mkexp (Pexp_newtype (newtype, exp)))
newtypes exp
let wrap_type_annotation newtypes core_type body =
let exp = mkexp(Pexp_constraint(body,core_type)) in
let exp = mk_newtypes newtypes exp in
- (exp, ghtyp(Ptyp_poly(newtypes,varify_constructors newtypes core_type)))
+ (exp, ghtyp(Ptyp_poly(newtypes, Typ.varify_constructors newtypes core_type)))
let wrap_exp_attrs body (ext, attrs) =
(* todo: keep exact location for the entire attribute *)
(fun acc (n, t) -> mkmod(Pmod_functor(n, t, acc)))
$5 $3
in wrap_mod_attrs modexp $2 }
- | module_expr LPAREN module_expr RPAREN
- { mkmod(Pmod_apply($1, $3)) }
+ | module_expr paren_module_expr
+ { mkmod(Pmod_apply($1, $2)) }
| module_expr LPAREN RPAREN
{ mkmod(Pmod_apply($1, mkmod (Pmod_structure []))) }
- | module_expr LPAREN module_expr error
- { unclosed "(" 2 ")" 4 }
- | LPAREN module_expr COLON module_type RPAREN
+ | paren_module_expr
+ { $1 }
+ | module_expr attribute
+ { Mod.attr $1 $2 }
+ | extension
+ { mkmod(Pmod_extension $1) }
+;
+
+paren_module_expr:
+ LPAREN module_expr COLON module_type RPAREN
{ mkmod(Pmod_constraint($2, $4)) }
| LPAREN module_expr COLON module_type error
{ unclosed "(" 1 ")" 5 }
{ unclosed "(" 1 ")" 6 }
| LPAREN VAL attributes expr error
{ unclosed "(" 1 ")" 5 }
- | module_expr attribute
- { Mod.attr $1 $2 }
- | extension
- { mkmod(Pmod_extension $1) }
;
structure:
;
parent_binder:
AS LIDENT
- { Some $2 }
+ { Some (mkrhs $2 2) }
| /* empty */
{ None }
;
post_item_attributes
{
let (p, v) = $3 in
- mkctf (Pctf_method ($4, p, v, $6)) ~attrs:($2@$7) ~docs:(symbol_docs ())
+ mkctf (Pctf_method (mkrhs $4 4, p, v, $6)) ~attrs:($2@$7) ~docs:(symbol_docs ())
}
| CONSTRAINT attributes constrain_field post_item_attributes
{ mkctf (Pctf_constraint $3) ~attrs:($2@$4) ~docs:(symbol_docs ()) }
;
value_type:
VIRTUAL mutable_flag label COLON core_type
- { $3, $2, Virtual, $5 }
+ { mkrhs $3 3, $2, Virtual, $5 }
| MUTABLE virtual_flag label COLON core_type
- { $3, Mutable, $2, $5 }
+ { mkrhs $3 3, Mutable, $2, $5 }
| label COLON core_type
- { $1, Immutable, Concrete, $3 }
+ { mkrhs $1 1, Immutable, Concrete, $3 }
;
constrain:
core_type EQUAL core_type { $1, $3, symbol_rloc() }
| mod_longident DOT LBRACELESS field_expr_list error
{ unclosed "{<" 3 ">}" 5 }
| simple_expr HASH label
- { mkexp(Pexp_send($1, $3)) }
+ { mkexp(Pexp_send($1, mkrhs $3 3)) }
| simple_expr HASHOP simple_expr
{ mkinfix $1 $2 $3 }
| LPAREN MODULE ext_attributes module_expr RPAREN
LIDENT { ($1, mkexp(Pexp_ident(mkrhs (Lident $1) 1))) }
;
lident_list:
- LIDENT { [$1] }
- | LIDENT lident_list { $1 :: $2 }
+ LIDENT { [mkrhs $1 1] }
+ | LIDENT lident_list { mkrhs $1 1 :: $2 }
;
let_binding_body:
val_ident fun_binding
/* Polymorphic types */
typevar_list:
- QUOTE ident { [$2] }
- | typevar_list QUOTE ident { $3 :: $1 }
+ QUOTE ident { [mkrhs $2 2] }
+ | typevar_list QUOTE ident { mkrhs $3 3 :: $1 }
;
poly_type:
core_type
;
field:
label COLON poly_type_no_attr attributes
- { ($1, add_info_attrs (symbol_info ()) $4, $3) }
+ { (mkrhs $1 1, add_info_attrs (symbol_info ()) $4, $3) }
;
field_semi:
| Some _ as info_before_semi -> info_before_semi
| None -> symbol_info ()
in
- ($1, add_info_attrs info ($4 @ $6), $3) }
+ (mkrhs $1 1, add_info_attrs info ($4 @ $6), $3) }
;
label:
T tconstr
(T1, ..., Tn) tconstr
*)
- | Ptyp_object of (string * attributes * core_type) list * closed_flag
+ | Ptyp_object of (string loc * attributes * core_type) list * closed_flag
(* < l1:T1; ...; ln:Tn > (flag = Closed)
< l1:T1; ...; ln:Tn; .. > (flag = Open)
*)
[< `A|`B ] (flag = Closed; labels = Some [])
[< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"])
*)
- | Ptyp_poly of string list * core_type
+ | Ptyp_poly of string loc list * core_type
(* 'a1 ... 'an. T
Can only appear in the following context:
| Ppat_extension of extension
(* [%id] *)
| Ppat_open of Longident.t loc * pattern
+ (* M.(P) *)
(* Value expressions *)
(* (E :> T) (None, T)
(E : T0 :> T) (Some T0, T)
*)
- | Pexp_send of expression * string
+ | Pexp_send of expression * string loc
(* E # m *)
| Pexp_new of Longident.t loc
(* new M.c *)
for methods (not values). *)
| Pexp_object of class_structure
(* object ... end *)
- | Pexp_newtype of string * expression
+ | Pexp_newtype of string loc * expression
(* fun (type t) -> E *)
| Pexp_pack of module_expr
(* (module ME)
(module ME : S) is represented as
Pexp_constraint(Pexp_pack, Ptyp_package S) *)
| Pexp_open of override_flag * Longident.t loc * expression
- (* let open M in E
- let! open M in E
- *)
+ (* M.(E)
+ let open M in E
+ let! open M in E *)
| Pexp_extension of extension
(* [%id] *)
| Pexp_unreachable
and class_type_field_desc =
| Pctf_inherit of class_type
(* inherit CT *)
- | Pctf_val of (string * mutable_flag * virtual_flag * core_type)
+ | Pctf_val of (string loc * mutable_flag * virtual_flag * core_type)
(* val x: T *)
- | Pctf_method of (string * private_flag * virtual_flag * core_type)
+ | Pctf_method of (string loc * private_flag * virtual_flag * core_type)
(* method x: T
Note: T can be a Ptyp_poly.
}
and class_field_desc =
- | Pcf_inherit of override_flag * class_expr * string option
+ | Pcf_inherit of override_flag * class_expr * string loc option
(* inherit CE
inherit CE as x
inherit! CE
open Location
open Longident
open Parsetree
+open Ast_helper
let prefix_symbols = [ '!'; '?'; '~' ] ;;
let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/';
let view_fixity_of_exp = function
| {pexp_desc = Pexp_ident {txt=Lident l;_};_} -> fixity_of_string l
- | _ -> `Normal ;;
+ | _ -> `Normal
let is_infix = function | `Infix _ -> true | _ -> false
let constant_string f s = pp f "%S" s
let tyvar f str = pp f "'%s" str
+let tyvar_loc f str = pp f "'%s" str.txt
let string_quot f x = pp f "`%s" x
(* c ['a,'b] *)
| [] -> ()
| _ ->
pp f "%a@;.@;"
- (list tyvar ~sep:"@;") l)
+ (list tyvar_loc ~sep:"@;") l)
l)
sl (core_type ctxt) ct
| _ -> pp f "@[<2>%a@]" (core_type1 ctxt) x
(list string_quot) xs) low
| Ptyp_object (l, o) ->
let core_field_type f (s, attrs, ct) =
- pp f "@[<hov2>%s: %a@ %a@ @]" s
+ pp f "@[<hov2>%s: %a@ %a@ @]" s.txt
(core_type ctxt) ct (attributes ctxt) attrs (* Cf #7200 *)
in
let field_var f = function
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
+ | [(Nolabel, x)] ->
+ pp f "@[<2>%s@;%a@]" s (simple_expr ctxt) x
| _ ->
pp f "@[<2>%a %a@]" (simple_expr ctxt) e
(list (label_x_expression_param ctxt)) l
| _ -> assert false)
| Pexp_setfield (e1, li, e2) ->
pp f "@[<2>%a.%a@ <-@ %a@]"
- (simple_expr ctxt) e1 longident_loc li (expression ctxt) e2
+ (simple_expr ctxt) e1 longident_loc li (simple_expr ctxt) e2
| Pexp_ifthenelse (e1, e2, eo) ->
(* @;@[<2>else@ %a@]@] *)
let fmt:(_,_,_)format ="@[<hv0>@[<2>if@ %a@]@;@[<2>then@ %a@]%a@]" in
else match x.pexp_desc with
| Pexp_field (e, li) ->
pp f "@[<hov2>%a.%a@]" (simple_expr ctxt) e longident_loc li
- | Pexp_send (e, s) -> pp f "@[<hov2>%a#%s@]" (simple_expr ctxt) e s
+ | Pexp_send (e, s) -> pp f "@[<hov2>%a#%s@]" (simple_expr ctxt) e s.txt
| _ -> simple_expr ctxt f x
| Pexp_pack me ->
pp f "(module@;%a)" (module_expr ctxt) me
| Pexp_newtype (lid, e) ->
- pp f "fun@;(type@;%s)@;->@;%a" lid (expression ctxt) e
+ pp f "fun@;(type@;%s)@;->@;%a" lid.txt (expression ctxt) e
| Pexp_tuple l ->
pp f "@[<hov2>(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l
| Pexp_constraint (e, ct) ->
(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
+ mutable_flag mf virtual_flag vf s.txt (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
+ private_flag pf virtual_flag vf s.txt (core_type ctxt) ct
(item_attributes ctxt) x.pctf_attributes
| Pctf_constraint (ct1, ct2) ->
pp f "@[<2>constraint@ %a@ =@ %a@]%a"
(class_expr ctxt) ce
(fun f so -> match so with
| None -> ();
- | Some (s) -> pp f "@ as %s" s ) so
+ | Some (s) -> pp f "@ as %s" s.txt ) 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)
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 "(type@ %s)@ %a" str.txt pp_print_pexp_function e
| _ -> pp f "=@;%a" (expression ctxt) x
in
+ let tyvars_str tyvars = List.map (fun v -> v.txt) tyvars in
+ let is_desugared_gadt p e =
+ let gadt_pattern =
+ match p.ppat_desc with
+ | Ppat_constraint({ppat_desc=Ppat_var _} as pat,
+ {ptyp_desc=Ptyp_poly (args_tyvars, rt)}) ->
+ Some (pat, args_tyvars, rt)
+ | _ -> None in
+ let rec gadt_exp tyvars e =
+ match e.pexp_desc with
+ | Pexp_newtype (tyvar, e) -> gadt_exp (tyvar :: tyvars) e
+ | Pexp_constraint (e, ct) -> Some (List.rev tyvars, e, ct)
+ | _ -> None in
+ let gadt_exp = gadt_exp [] e in
+ match gadt_pattern, gadt_exp with
+ | Some (p, pt_tyvars, pt_ct), Some (e_tyvars, e, e_ct)
+ when tyvars_str pt_tyvars = tyvars_str e_tyvars ->
+ let ety = Typ.varify_constructors e_tyvars e_ct in
+ if ety = pt_ct then
+ Some (p, pt_tyvars, e_ct, e) else None
+ | _ -> None 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*)
- begin match ty.ptyp_desc with
- | Ptyp_poly _ ->
- pp f "%a@;:@;%a@;=@;%a" (simple_pattern ctxt) p
- (core_type ctxt) ty (expression ctxt) 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
- (core_type ctxt) t1 (expression ctxt) e
- | (_, Ppat_var _) ->
- pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x
- | _ ->
- pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x
+ then pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x else
+ match is_desugared_gadt p x with
+ | Some (p, tyvars, ct, e) -> begin
+ pp f "%a@;: type@;%a.%a@;=@;%a"
+ (simple_pattern ctxt) p (list pp_print_string ~sep:"@;")
+ (tyvars_str tyvars) (core_type ctxt) ct (expression ctxt) e
+ end
+ | None -> begin
+ match (x.pexp_desc,p.ppat_desc) with
+ | ( _ , Ppat_constraint( p ,ty)) -> (* special case for the first*)
+ begin match ty.ptyp_desc with
+ | Ptyp_poly _ ->
+ pp f "%a@;:@;%a@;=@;%a" (simple_pattern ctxt) p
+ (core_type ctxt) ty (expression ctxt) x
+ | _ ->
+ pp f "(%a@;:@;%a)@;=@;%a" (simple_pattern ctxt) p
+ (core_type ctxt) ty (expression ctxt) x
+ end
+ | (_, Ppat_var _) ->
+ pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x
+ | _ ->
+ pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x
+ end
(* [in] is not printed *)
and bindings ctxt f (rf,l) =
let i = i + 1 in
List.iter
(fun (s, attrs, t) ->
- line i ppf "method %s\n" s;
+ line i ppf "method %s\n" s.txt;
attributes i ppf attrs;
core_type (i + 1) ppf t
)
core_type i ppf ct;
| Ptyp_poly (sl, ct) ->
line i ppf "Ptyp_poly%a\n"
- (fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x)) sl;
+ (fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x.txt)) sl;
core_type i ppf ct;
| Ptyp_package (s, l) ->
line i ppf "Ptyp_package %a\n" fmt_longident_loc s;
option i core_type ppf cto1;
core_type i ppf cto2;
| Pexp_send (e, s) ->
- line i ppf "Pexp_send \"%s\"\n" s;
+ line i ppf "Pexp_send \"%s\"\n" s.txt;
expression i ppf e;
| Pexp_new (li) -> line i ppf "Pexp_new %a\n" fmt_longident_loc li;
| Pexp_setinstvar (s, e) ->
line i ppf "Pexp_object\n";
class_structure i ppf s
| Pexp_newtype (s, e) ->
- line i ppf "Pexp_newtype \"%s\"\n" s;
+ line i ppf "Pexp_newtype \"%s\"\n" s.txt;
expression i ppf e
| Pexp_pack me ->
line i ppf "Pexp_pack\n";
line i ppf "Pctf_inherit\n";
class_type i ppf ct;
| Pctf_val (s, mf, vf, ct) ->
- line i ppf "Pctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf
+ line i ppf "Pctf_val \"%s\" %a %a\n" s.txt fmt_mutable_flag mf
fmt_virtual_flag vf;
core_type (i+1) ppf ct;
| Pctf_method (s, pf, vf, ct) ->
- line i ppf "Pctf_method \"%s\" %a %a\n" s fmt_private_flag pf
+ line i ppf "Pctf_method \"%s\" %a %a\n" s.txt fmt_private_flag pf
fmt_virtual_flag vf;
core_type (i+1) ppf ct;
| Pctf_constraint (ct1, ct2) ->
| Pcf_inherit (ovf, ce, so) ->
line i ppf "Pcf_inherit %a\n" fmt_override_flag ovf;
class_expr (i+1) ppf ce;
- option (i+1) string ppf so;
+ option (i+1) string_loc ppf so;
| Pcf_val (s, mf, k) ->
line i ppf "Pcf_val %a\n" fmt_mutable_flag mf;
line (i+1) ppf "%a\n" fmt_string_loc s;
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
+uchar.cmo : pervasives.cmi char.cmi uchar.cmi
+uchar.cmx : pervasives.cmx char.cmx uchar.cmi
+uchar.cmi :
weak.cmo : sys.cmi obj.cmi hashtbl.cmi array.cmi weak.cmi
weak.cmx : sys.cmx obj.cmx hashtbl.cmx array.cmx weak.cmi
weak.cmi : hashtbl.cmi
stringLabels.p.cmx : string.cmx stringLabels.cmi
sys.cmo : sys.cmi
sys.p.cmx : sys.cmi
-uchar.cmo : printf.cmi pervasives.cmi format.cmi char.cmi uchar.cmi
-uchar.p.cmx : printf.cmx pervasives.cmx format.cmx char.cmx uchar.cmi
+uchar.cmo : pervasives.cmi char.cmi uchar.cmi
+uchar.p.cmx : pervasives.cmx char.cmx uchar.cmi
weak.cmo : sys.cmi obj.cmi hashtbl.cmi array.cmi weak.cmi
weak.p.cmx : sys.cmx obj.cmx hashtbl.cmx array.cmx weak.cmi
#* *
#**************************************************************************
-include Makefile.shared
+include ../config/Makefile
+CAMLRUN ?= ../boot/ocamlrun
+CAMLYACC ?= ../boot/ocamlyacc
+TARGET_BINDIR ?= $(BINDIR)
-allopt:
- $(MAKE) stdlib.cmxa std_exit.cmx
- $(MAKE) allopt-$(PROFILING)
+COMPILER=../ocamlc
+CAMLC=$(CAMLRUN) $(COMPILER)
+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
+OPTCOMPFLAGS=
+endif
+OPTCOMPILER=../ocamlopt
+CAMLOPT=$(CAMLRUN) $(OPTCOMPILER)
+CAMLDEP=$(CAMLRUN) ../tools/ocamldep
+OBJS=camlinternalFormatBasics.cmo pervasives.cmo $(OTHERS)
+OTHERS=list.cmo char.cmo uchar.cmo bytes.cmo string.cmo sys.cmo \
+ sort.cmo marshal.cmo obj.cmo array.cmo \
+ int32.cmo int64.cmo nativeint.cmo \
+ lexing.cmo parsing.cmo \
+ set.cmo map.cmo stack.cmo queue.cmo \
+ camlinternalLazy.cmo lazy.cmo stream.cmo \
+ buffer.cmo camlinternalFormat.cmo printf.cmo \
+ arg.cmo printexc.cmo gc.cmo \
+ digest.cmo random.cmo hashtbl.cmo weak.cmo \
+ format.cmo scanf.cmo callback.cmo \
+ camlinternalOO.cmo oo.cmo camlinternalMod.cmo \
+ genlex.cmo ephemeron.cmo \
+ filename.cmo complex.cmo \
+ arrayLabels.cmo listLabels.cmo bytesLabels.cmo \
+ stringLabels.cmo moreLabels.cmo stdLabels.cmo \
+ spacetime.cmo
+
+.PHONY: all
+all: stdlib.cma std_exit.cmo camlheader target_camlheader camlheader_ur
+
+ifeq "$(RUNTIMED)" "true"
+all: camlheaderd
+endif
+
+ifeq "$(RUNTIMEI)" "true"
+all: camlheaderi
+endif
+
+ifeq "$(PROFILING)" "true"
+PROFILINGTARGET = prof
+else
+PROFILINGTARGET = noprof
+endif
+
+.PHONY: allopt
+allopt: stdlib.cmxa std_exit.cmx allopt-$(PROFILINGTARGET)
+
+.PHONY: allopt-noprof
allopt-noprof:
+.PHONY: allopt-prof
allopt-prof: stdlib.p.cmxa std_exit.p.cmx
rm -f std_exit.p.cmi
-installopt: installopt-default installopt-$(PROFILING)
+INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
+
+.PHONY: install
+install::
+ cp stdlib.cma std_exit.cmo *.cmi *.cmt *.cmti *.mli *.ml \
+ camlheader_ur \
+ "$(INSTALL_LIBDIR)"
+ cp target_camlheader "$(INSTALL_LIBDIR)/camlheader"
+
+ifeq "$(RUNTIMED)" "true"
+install::
+ cp target_camlheaderd $(INSTALL_LIBDIR)
+endif
+
+ifeq "$(RUNTIMEI)" "true"
+install::
+ cp target_camlheaderi $(INSTALL_LIBDIR)
+endif
+.PHONY: installopt
+installopt: installopt-default installopt-$(PROFILINGTARGET)
+
+.PHONY: installopt-default
installopt-default:
- cp stdlib.cmxa stdlib.a std_exit.o *.cmx "$(INSTALL_LIBDIR)"
- cd "$(INSTALL_LIBDIR)"; $(RANLIB) stdlib.a
+ cp stdlib.cmxa stdlib.$(A) std_exit.$(O) *.cmx "$(INSTALL_LIBDIR)"
+ cd "$(INSTALL_LIBDIR)"; $(RANLIB) stdlib.$(A)
+.PHONY: installopt-noprof
installopt-noprof:
- rm -f "$(INSTALL_LIBDIR)/stdlib.p.cmxa"; \
- ln -s stdlib.cmxa "$(INSTALL_LIBDIR)/stdlib.p.cmxa"
- rm -f "$(INSTALL_LIBDIR)/stdlib.p.a"; \
- ln -s stdlib.a "$(INSTALL_LIBDIR)/stdlib.p.a"
- rm -f "$(INSTALL_LIBDIR)/std_exit.p.cmx"; \
- ln -s std_exit.cmx "$(INSTALL_LIBDIR)/std_exit.p.cmx"
- rm -f "$(INSTALL_LIBDIR)/std_exit.p.o"; \
- ln -s std_exit.o "$(INSTALL_LIBDIR)/std_exit.p.o"
+.PHONY: installopt-prof
installopt-prof:
- cp stdlib.p.cmxa stdlib.p.a std_exit.p.cmx std_exit.p.o \
+ cp stdlib.p.cmxa stdlib.p.$(A) std_exit.p.cmx std_exit.p.$(O) \
"$(INSTALL_LIBDIR)"
- cd "$(INSTALL_LIBDIR)"; $(RANLIB) stdlib.p.a
+ cd "$(INSTALL_LIBDIR)"; $(RANLIB) stdlib.p.$(A)
+
+ifeq "$(UNIX_OR_WIN32)" "unix"
+HEADERPROGRAM = header.c
+else # Windows
+HEADERPROGRAM = headernt.c
+endif
+
+CAMLHEADERS =\
+ camlheader target_camlheader camlheader_ur \
+ camlheaderd target_camlheaderd \
+ camlheaderi target_camlheaderi
+
+ifeq "$(HASHBANGSCRIPTS)" "true"
+$(CAMLHEADERS): ../config/Makefile
+ for suff in '' d i; do \
+ echo '#!$(BINDIR)/ocamlrun'$$suff > camlheader$$suff && \
+ echo '#!$(TARGET_BINDIR)/ocamlrun'$$suff >target_camlheader$$suff; \
+ done && \
+ echo '#!' | tr -d '\012' > camlheader_ur;
+else # Hashbang scripts not supported
+
+$(CAMLHEADERS): $(HEADERPROGRAM) ../config/Makefile
+
+ifeq "$(UNIX_OR_WIN32)" "unix"
+$(CAMLHEADERS):
+ for suff in '' d i; do \
+ $(BYTECC) $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) \
+ -DRUNTIME_NAME='"$(BINDIR)/ocamlrun'$$suff'"' \
+ header.c -o tmpheader$(EXE) && \
+ strip tmpheader$(EXE) && \
+ mv tmpheader$(EXE) camlheader$$suff && \
+ $(BYTECC) $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) \
+ -DRUNTIME_NAME='"$(TARGET_BINDIR)/ocamlrun'$$suff'"' \
+ header.c -o tmpheader$(EXE) && \
+ strip tmpheader$(EXE) && \
+ mv tmpheader$(EXE) target_camlheader$$suff; \
+ done && \
+ cp camlheader camlheader_ur
+
+else # Windows
+
+# TODO: see whether there is a way to further merge the rules below
+# with those above
+
+camlheader target_camlheader camlheader_ur:
+ $(BYTECC) $(BYTECCCOMPOPTS) -c -I../byterun \
+ -DRUNTIME_NAME='"ocamlrun"' headernt.c
+ $(MKEXE) -o tmpheader.exe headernt.$(O) $(EXTRALIBS)
+ rm -f camlheader.exe
+ mv tmpheader.exe camlheader
+ cp camlheader target_camlheader
+ cp camlheader camlheader_ur
+
+camlheaderd target_camlheaderd:
+ $(BYTECC) $(BYTECCCOMPOPTS) -c -I../byterun \
+ -DRUNTIME_NAME='"ocamlrund"' headernt.c
+ $(MKEXE) -o tmpheader.exe headernt.$(O) $(EXTRALIBS)
+ mv tmpheader.exe camlheaderd
+ cp camlheaderd target_camlheaderd
+
+camlheaderi:
+ $(BYTECC) $(BYTECCCOMPOPTS) -c -I../byterun \
+ -DRUNTIME_NAME='"ocamlruni"' headernt.c
+ $(MKEXE) -o tmpheader.exe headernt.$(O) $(EXTRALIBS)
+ mv tmpheader.exe camlheaderi
+
+# TODO: do not call flexlink to build tmpheader.exe (we don't need
+# the export table)
+
+endif # ifeq "$(UNIX_OR_WIN32)" "unix"
+
+endif # ifeq "$(HASHBANGSCRIPTS)" "true"
+
+stdlib.cma: $(OBJS)
+ $(CAMLC) -a -o $@ $^
+
+stdlib.cmxa: $(OBJS:.cmo=.cmx)
+ $(CAMLOPT) -a -o $@ $^
stdlib.p.cmxa: $(OBJS:.cmo=.p.cmx)
- $(CAMLOPT) -a -o stdlib.p.cmxa $(OBJS:.cmo=.p.cmx)
-
-camlheader target_camlheader camlheader_ur \
-camlheaderd target_camlheaderd \
-camlheaderi target_camlheaderi: \
- header.c ../config/Makefile
- if $(HASHBANGSCRIPTS); then \
- for suff in '' d i; do \
- echo '#!$(BINDIR)/ocamlrun'$$suff > camlheader$$suff && \
- echo '#!$(TARGET_BINDIR)/ocamlrun'$$suff >target_camlheader$$suff; \
- done && \
- echo '#!' | tr -d '\012' > camlheader_ur; \
- else \
- for suff in '' d i; do \
- $(BYTECC) $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) \
- -DRUNTIME_NAME='"$(BINDIR)/ocamlrun'$$suff'"' \
- header.c -o tmpheader$(EXE) && \
- strip tmpheader$(EXE) && \
- mv tmpheader$(EXE) camlheader$$suff && \
- $(BYTECC) $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) \
- -DRUNTIME_NAME='"$(TARGET_BINDIR)/ocamlrun'$$suff'"' \
- header.c -o tmpheader$(EXE) && \
- strip tmpheader$(EXE) && \
- mv tmpheader$(EXE) target_camlheader$$suff; \
- done && \
- cp camlheader camlheader_ur; \
- fi
-
-.PHONY: all allopt allopt-noprof allopt-prof install installopt
-.PHONY: installopt-default installopt-noprof installopt-prof clean depend
+ $(CAMLOPT) -a -o $@ $^
+
+sys.ml: sys.mlp ../VERSION
+ sed -e "s|%%VERSION%%|`sed -e 1q ../VERSION | tr -d '\r'`|" sys.mlp > $@
+
+.PHONY: clean
+clean::
+ rm -f sys.ml
+
+clean::
+ rm -f $(CAMLHEADERS)
+
+.SUFFIXES: .mli .ml .cmi .cmo .cmx .p.cmx
+
+.mli.cmi:
+ $(CAMLC) $(COMPFLAGS) `sh ./Compflags $@` -c $<
+
+.ml.cmo:
+ $(CAMLC) $(COMPFLAGS) `sh ./Compflags $@` -c $<
+
+.ml.cmx:
+ $(CAMLOPT) $(COMPFLAGS) $(OPTCOMPFLAGS) `sh ./Compflags $@` -c $<
+
+.ml.p.cmx:
+ $(CAMLOPT) $(COMPFLAGS) $(OPTCOMPFLAGS) `sh ./Compflags $@` \
+ -p -c -o $*.p.cmx $<
+
+# Dependencies on the 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)
+
+# Dependencies on Pervasives (not tracked by ocamldep)
+$(OTHERS) std_exit.cmo: pervasives.cmi
+$(OTHERS:.cmo=.cmi) std_exit.cmi: pervasives.cmi
+$(OBJS:.cmo=.cmx) std_exit.cmx: pervasives.cmi
+$(OBJS:.cmo=.p.cmx) std_exit.p.cmx: pervasives.cmi
+$(OTHERS:.cmo=.cmx) std_exit.cmx: pervasives.cmx
+$(OTHERS:.cmo=.p.cmx) std_exit.p.cmx: pervasives.cmx
+
+clean::
+ rm -f *.cm* *.$(O) *.$(A)
+ rm -f *~
+ rm -f camlheader*
+
+include .depend
+
+# Note that .p.cmx targets do not depend (for compilation) upon other
+# .p.cmx files. When the compiler imports another compilation unit,
+# it looks for the .cmx file (not .p.cmx).
+.PHONY: depend
+depend:
+ $(CAMLDEP) -slash *.mli *.ml > .depend
+ $(CAMLDEP) -slash *.ml | sed -e 's/\.cmx : /.p.cmx : /g' >>.depend
#* *
#**************************************************************************
-include Makefile.shared
-
-allopt: stdlib.cmxa std_exit.cmx
-
-installopt:
- cp stdlib.cmxa stdlib.$(A) std_exit.$(O) *.cmx "$(INSTALL_LIBDIR)"
-
-camlheader target_camlheader camlheader_ur: headernt.c ../config/Makefile
- $(BYTECC) $(BYTECCCOMPOPTS) -c -I../byterun \
- -DRUNTIME_NAME='"ocamlrun"' headernt.c
- $(MKEXE) -o tmpheader.exe headernt.$(O) $(EXTRALIBS)
- rm -f camlheader.exe
- mv tmpheader.exe camlheader
- cp camlheader target_camlheader
- cp camlheader camlheader_ur
-
-camlheaderd target_camlheaderd: headernt.c ../config/Makefile
- $(BYTECC) $(BYTECCCOMPOPTS) -c -I../byterun \
- -DRUNTIME_NAME='"ocamlrund"' headernt.c
- $(MKEXE) -o tmpheader.exe headernt.$(O) $(EXTRALIBS)
- mv tmpheader.exe camlheaderd
- cp camlheaderd target_camlheaderd
-
-camlheaderi: headernt.c ../config/Makefile
- $(BYTECC) $(BYTECCCOMPOPTS) -c -I../byterun \
- -DRUNTIME_NAME='"ocamlruni"' headernt.c
- $(MKEXE) -o tmpheader.exe headernt.$(O) $(EXTRALIBS)
- mv tmpheader.exe camlheaderi
-
-# TODO: do not call flexlink to build tmpheader.exe (we don't need
-# the export table)
+include Makefile
+++ /dev/null
-#**************************************************************************
-#* *
-#* 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 ../config/Makefile
-CAMLRUN ?= ../boot/ocamlrun
-CAMLYACC ?= ../boot/ocamlyacc
-TARGET_BINDIR ?= $(BINDIR)
-
-COMPILER=../ocamlc
-CAMLC=$(CAMLRUN) $(COMPILER)
-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
-OPTCOMPFLAGS=
-endif
-OPTCOMPILER=../ocamlopt
-CAMLOPT=$(CAMLRUN) $(OPTCOMPILER)
-CAMLDEP=$(CAMLRUN) ../tools/ocamldep
-
-OBJS=camlinternalFormatBasics.cmo pervasives.cmo $(OTHERS)
-OTHERS=list.cmo char.cmo bytes.cmo string.cmo sys.cmo \
- sort.cmo marshal.cmo obj.cmo array.cmo \
- int32.cmo int64.cmo nativeint.cmo \
- lexing.cmo parsing.cmo \
- set.cmo map.cmo stack.cmo queue.cmo \
- camlinternalLazy.cmo lazy.cmo stream.cmo \
- buffer.cmo camlinternalFormat.cmo printf.cmo \
- arg.cmo printexc.cmo gc.cmo \
- digest.cmo random.cmo hashtbl.cmo weak.cmo \
- format.cmo uchar.cmo scanf.cmo callback.cmo \
- camlinternalOO.cmo oo.cmo camlinternalMod.cmo \
- genlex.cmo ephemeron.cmo \
- filename.cmo complex.cmo \
- arrayLabels.cmo listLabels.cmo bytesLabels.cmo \
- stringLabels.cmo moreLabels.cmo stdLabels.cmo \
- spacetime.cmo
-
-all: stdlib.cma std_exit.cmo camlheader target_camlheader camlheader_ur
-
-ifeq "$(RUNTIMED)" "runtimed"
-all: camlheaderd
-endif
-
-ifeq "$(RUNTIMEI)" "true"
-all: camlheaderi
-endif
-
-INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
-
-install::
- cp stdlib.cma std_exit.cmo *.cmi *.cmt *.cmti *.mli *.ml \
- camlheader_ur \
- "$(INSTALL_LIBDIR)"
- cp target_camlheader "$(INSTALL_LIBDIR)/camlheader"
-
-ifeq "$(RUNTIMED)" "runtimed"
-install::
- cp target_camlheaderd $(INSTALL_LIBDIR)
-endif
-
-ifeq "$(RUNTIMEI)" "true"
-install::
- cp target_camlheaderi $(INSTALL_LIBDIR)
-endif
-
-stdlib.cma: $(OBJS)
- $(CAMLC) -a -o stdlib.cma $(OBJS)
-
-stdlib.cmxa: $(OBJS:.cmo=.cmx)
- $(CAMLOPT) -a -o stdlib.cmxa $(OBJS:.cmo=.cmx)
-
-sys.ml: sys.mlp ../VERSION
- sed -e "s|%%VERSION%%|`sed -e 1q ../VERSION`|" sys.mlp >sys.ml
-
-clean::
- rm -f sys.ml
-
-clean::
- rm -f camlheader target_camlheader camlheader_ur target_camlheader[di]
-
-.SUFFIXES: .mli .ml .cmi .cmo .cmx .p.cmx
-
-.mli.cmi:
- $(CAMLC) $(COMPFLAGS) `./Compflags $@` -c $<
-
-.ml.cmo:
- $(CAMLC) $(COMPFLAGS) `./Compflags $@` -c $<
-
-.ml.cmx:
- $(CAMLOPT) $(COMPFLAGS) $(OPTCOMPFLAGS) `./Compflags $@` -c $<
-
-.ml.p.cmx:
- $(CAMLOPT) $(COMPFLAGS) $(OPTCOMPFLAGS) `./Compflags $@` \
- -p -c -o $*.p.cmx $<
-
-# Dependencies on the 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)
-
-# Dependencies on Pervasives (not tracked by ocamldep)
-$(OTHERS) std_exit.cmo: pervasives.cmi
-$(OTHERS:.cmo=.cmi) std_exit.cmi: pervasives.cmi
-$(OBJS:.cmo=.cmx) std_exit.cmx: pervasives.cmi
-$(OBJS:.cmo=.p.cmx) std_exit.p.cmx: pervasives.cmi
-$(OTHERS:.cmo=.cmx) std_exit.cmx: pervasives.cmx
-$(OTHERS:.cmo=.p.cmx) std_exit.p.cmx: pervasives.cmx
-
-clean::
- rm -f *.cm* *.$(O) *.$(A)
- rm -f *~
- rm -f camlheader*
-
-include .depend
-
-# Note that .p.cmx targets do not depend (for compilation) upon other
-# .p.cmx files. When the compiler imports another compilation unit,
-# it looks for the .cmx file (not .p.cmx).
-depend:
- $(CAMLDEP) -slash *.mli *.ml > .depend
- $(CAMLDEP) -slash *.ml | sed -e 's/\.cmx : /.p.cmx : /g' >>.depend
char \
complex \
digest \
+ ephemeron \
filename \
format \
gc \
call the function with the symbol. *)
| Rest of (string -> unit) (* Stop interpreting keywords and call the
function with each remaining argument *)
+ | Expand of (string -> string array) (* If the remaining arguments to process
+ are of the form
+ [["-foo"; "arg"] @ rest] where "foo" is
+ registered as [Expand f], then the
+ arguments [f "arg" @ rest] are
+ processed. Only allowed in
+ [parse_and_expand_argv_dynamic]. *)
exception Bad of string
exception Help of string
try Some (float_of_string x)
with Failure _ -> None
-let parse_argv_dynamic ?(current=current) argv speclist anonfun errmsg =
- let l = Array.length argv in
- let b = Buffer.create 200 in
+let parse_and_expand_argv_dynamic_aux allow_expand current argv speclist anonfun errmsg =
let initpos = !current in
- let stop error =
- let progname = if initpos < l then argv.(initpos) else "(?)" in
+ let convert_error error =
+ (* convert an internal error to a Bad/Help exception
+ *or* add the program name as a prefix and the usage message as a suffix
+ to an user-raised Bad exception.
+ *)
+ let b = Buffer.create 200 in
+ let progname = if initpos < (Array.length !argv) then !argv.(initpos) else "(?)" in
begin match error with
| Unknown "-help" -> ()
| Unknown "--help" -> ()
| Wrong (opt, arg, expected) ->
bprintf b "%s: wrong argument '%s'; option '%s' expects %s.\n"
progname arg opt expected
- | Message s ->
+ | Message s -> (* user error message *)
bprintf b "%s: %s.\n" progname s
end;
usage_b b !speclist errmsg;
if error = Unknown "-help" || error = Unknown "--help"
- then raise (Help (Buffer.contents b))
- else raise (Bad (Buffer.contents b))
+ then Help (Buffer.contents b)
+ else Bad (Buffer.contents b)
in
incr current;
- while !current < l do
- let s = argv.(!current) in
- if String.length s >= 1 && s.[0] = '-' then begin
- let action, follow =
- try assoc3 s !speclist, None
- with Not_found ->
+ while !current < (Array.length !argv) do
+ begin try
+ let s = !argv.(!current) in
+ if String.length s >= 1 && s.[0] = '-' then begin
+ let action, follow =
+ try assoc3 s !speclist, None
+ with Not_found ->
try
let keyword, arg = split s in
assoc3 keyword !speclist, Some arg
- with Not_found -> stop (Unknown s)
- in
- let no_arg () =
- match follow with
- | None -> ()
- | Some arg -> stop (Wrong (s, arg, "no argument")) in
- let get_arg () =
- match follow with
- | None ->
- if !current + 1 < l then argv.(!current + 1)
- else stop (Missing s)
- | Some arg -> arg
- in
- let consume_arg () =
- match follow with
- | None -> incr current
- | Some _ -> ()
- in
- begin try
+ with Not_found -> raise (Stop (Unknown s))
+ in
+ let no_arg () =
+ match follow with
+ | None -> ()
+ | Some arg -> raise (Stop (Wrong (s, arg, "no argument"))) in
+ let get_arg () =
+ match follow with
+ | None ->
+ if !current + 1 < (Array.length !argv) then !argv.(!current + 1)
+ else raise (Stop (Missing s))
+ | Some arg -> arg
+ in
+ let consume_arg () =
+ match follow with
+ | None -> incr current
+ | Some _ -> ()
+ in
let rec treat_action = function
| Unit f -> f ();
| Bool f ->
| Tuple specs ->
List.iter treat_action specs;
| Rest f ->
- while !current < l - 1 do
- f argv.(!current + 1);
+ while !current < (Array.length !argv) - 1 do
+ f !argv.(!current + 1);
consume_arg ();
done;
+ | Expand f ->
+ if not allow_expand then
+ raise (Invalid_argument "Arg.Expand is is only allowed with Arg.parse_and_expand_argv_dynamic");
+ let arg = get_arg () in
+ let newarg = f arg in
+ consume_arg ();
+ let before = Array.sub !argv 0 (!current + 1)
+ and after = Array.sub !argv (!current + 1) ((Array.length !argv) - !current - 1) in
+ argv:= Array.concat [before;newarg;after];
in
- treat_action action
- with Bad m -> stop (Message m);
- | Stop e -> stop e;
- end;
- incr current;
- end else begin
- (try anonfun s with Bad m -> stop (Message m));
- incr current;
+ treat_action action end
+ else anonfun s
+ with | Bad m -> raise (convert_error (Message m));
+ | Stop e -> raise (convert_error e);
end;
+ incr current
done
+let parse_and_expand_argv_dynamic current argv speclist anonfun errmsg =
+ parse_and_expand_argv_dynamic_aux true current argv speclist anonfun errmsg
+
+let parse_argv_dynamic ?(current=current) argv speclist anonfun errmsg =
+ parse_and_expand_argv_dynamic_aux false current (ref argv) speclist anonfun errmsg
+
let parse_argv ?(current=current) argv speclist anonfun errmsg =
parse_argv_dynamic ~current:current argv (ref speclist) anonfun errmsg
| Bad msg -> eprintf "%s" msg; exit 2
| Help msg -> printf "%s" msg; exit 0
+let parse_expand l f msg =
+ try
+ let argv = ref Sys.argv in
+ let spec = ref l in
+ let current = ref (!current) in
+ parse_and_expand_argv_dynamic current argv spec f msg
+ with
+ | Bad msg -> eprintf "%s" msg; exit 2
+ | Help msg -> printf "%s" msg; exit 0
+
let second_word s =
let len = String.length s in
let len = List.fold_left max_arg_len 0 completed in
let len = min len limit in
List.map (add_padding len) completed
+
+let trim_cr s =
+ let len = String.length s in
+ if len > 0 && String.get s (len - 1) = '\r' then
+ String.sub s 0 (len - 1)
+ else
+ s
+
+let read_aux trim sep file =
+ let ic = open_in_bin file in
+ let buf = Buffer.create 200 in
+ let words = ref [] in
+ let stash () =
+ let word = (Buffer.contents buf) in
+ let word = if trim then trim_cr word else word in
+ words := word :: !words;
+ Buffer.clear buf
+ in
+ let rec read () =
+ try
+ let c = input_char ic in
+ if c = sep then begin
+ stash (); read ()
+ end else begin
+ Buffer.add_char buf c; read ()
+ end
+ with End_of_file ->
+ if Buffer.length buf > 0 then
+ stash () in
+ read ();
+ close_in ic;
+ Array.of_list (List.rev !words)
+
+let read_arg = read_aux true '\n'
+
+let read_arg0 = read_aux false '\x00'
+
+let write_aux sep file args =
+ let oc = open_out_bin file in
+ Array.iter (fun s -> fprintf oc "%s%c" s sep) args;
+ close_out oc
+
+let write_arg = write_aux '\n'
+
+let write_arg0 = write_aux '\x00'
call the function with the symbol *)
| Rest of (string -> unit) (** Stop interpreting keywords and call the
function with each remaining argument *)
+ | Expand of (string -> string array) (** If the remaining arguments to process
+ are of the form
+ [["-foo"; "arg"] @ rest] where "foo" is
+ registered as [Expand f], then the
+ arguments [f "arg" @ rest] are
+ processed. Only allowed in
+ [parse_and_expand_argv_dynamic]. *)
(** The concrete type describing the behavior associated
with a keyword. *)
is to parse command lines of the form:
- command subcommand [options]
where the list of options depends on the value of the subcommand argument.
+ @since 4.01.0
*)
val parse_argv : ?current: int ref -> string array ->
(key * spec * doc) list -> anon_fun -> usage_msg -> unit
(** [Arg.parse_argv ~current args speclist anon_fun usage_msg] parses
the array [args] as if it were the command line. It uses and updates
- the value of [~current] (if given), or [Arg.current]. You must set
+ the value of [~current] (if given), or {!Arg.current}. You must set
it before calling [parse_argv]. The initial value of [current]
is the index of the program name (argument 0) in the array.
- If an error occurs, [Arg.parse_argv] raises [Arg.Bad] with
+ If an error occurs, [Arg.parse_argv] raises {!Arg.Bad} with
the error message as argument. If option [-help] or [--help] is
- given, [Arg.parse_argv] raises [Arg.Help] with the help message
+ given, [Arg.parse_argv] raises {!Arg.Help} with the help message
as argument.
*)
(** Same as {!Arg.parse_argv}, except that the [speclist] argument is a
reference and may be updated during the parsing.
See {!Arg.parse_dynamic}.
+ @since 4.01.0
+*)
+
+val parse_and_expand_argv_dynamic : int ref -> string array ref ->
+ (key * spec * doc) list ref -> anon_fun -> string -> unit
+(** Same as {!Arg.parse_argv_dynamic}, except that the [argv] argument is a
+ reference and may be updated during the parsing of [Expand] arguments.
+ See {!Arg.parse_argv_dynamic}.
+ @since 4.05.0
+*)
+
+val parse_expand:
+ (key * spec * doc) list -> anon_fun -> usage_msg -> unit
+(** Same as {!Arg.parse}, except that the [Expand] arguments are allowed and
+ the {!current} reference is not updated.
+ @since 4.05.0
*)
exception Help of string
exception Bad of string
(** Functions in [spec] or [anon_fun] can raise [Arg.Bad] with an error
message to reject invalid arguments.
- [Arg.Bad] is also raised by [Arg.parse_argv] in case of an error. *)
+ [Arg.Bad] is also raised by {!Arg.parse_argv} in case of an error. *)
val usage : (key * spec * doc) list -> usage_msg -> unit
(** [Arg.usage speclist usage_msg] prints to standard error
an error message that includes the list of valid options. This is
the same message that {!Arg.parse} prints in case of error.
- [speclist] and [usage_msg] are the same as for [Arg.parse]. *)
+ [speclist] and [usage_msg] are the same as for {!Arg.parse}. *)
val usage_string : (key * spec * doc) list -> usage_msg -> string
(** Returns the message that would have been printed by {!Arg.usage},
{!Arg.parse} uses the initial value of {!Arg.current} as the index of
argument 0 (the program name) and starts parsing arguments
at the next element. *)
+
+val read_arg: string -> string array
+(** [Arg.read_arg file] reads newline-terminated command line arguments from
+ file [file].
+ @since 4.05.0 *)
+
+val read_arg0: string -> string array
+(** Identical to {!Arg.read_arg} but assumes null character terminated command line
+ arguments.
+ @since 4.05.0 *)
+
+
+val write_arg: string -> string array -> unit
+(** [Arg.write_arg file args] writes the arguments [args] newline-terminated
+ into the file [file]. If the any of the arguments in [args] contains a
+ newline, use {!Arg.write_arg0} instead.
+ @since 4.05.0 *)
+
+val write_arg0: string -> string array -> unit
+(** Identical to {!Arg.write_arg} but uses the null character for terminator
+ instead of newline.
+ @since 4.05.0 *)
with the notation [m.(x).(y)].
Raise [Invalid_argument] if [dimx] or [dimy] is negative or
- greater than [Sys.max_array_length].
+ greater than {!Sys.max_array_length}.
If the value of [e] is a floating-point number, then the maximum
size is only [Sys.max_array_length / 2]. *)
concatenation of the arrays [v1] and [v2]. *)
val concat : 'a array list -> 'a array
-(** Same as [Array.append], but concatenates a list of arrays. *)
+(** Same as {!Array.append}, but concatenates a list of arrays. *)
val sub : 'a array -> int -> int -> 'a array
(** [Array.sub a start len] returns a fresh array of length [len],
(** Return the length (number of elements) of the given array. *)
external get : 'a array -> int -> 'a = "%array_safe_get"
-(** [ArrayLabels.get a n] returns the element number [n] of array [a].
+(** [Array.get a n] returns the element number [n] of array [a].
The first element has number 0.
- The last element has number [ArrayLabels.length a - 1].
- You can also write [a.(n)] instead of [ArrayLabels.get a n].
+ The last element has number [Array.length a - 1].
+ You can also write [a.(n)] instead of [Array.get a n].
Raise [Invalid_argument "index out of bounds"]
- if [n] is outside the range 0 to [(ArrayLabels.length a - 1)]. *)
+ if [n] is outside the range 0 to [(Array.length a - 1)]. *)
external set : 'a array -> int -> 'a -> unit = "%array_safe_set"
-(** [ArrayLabels.set a n x] modifies array [a] in place, replacing
+(** [Array.set a n x] modifies array [a] in place, replacing
element number [n] with [x].
- You can also write [a.(n) <- x] instead of [ArrayLabels.set a n x].
+ You can also write [a.(n) <- x] instead of [Array.set a n x].
Raise [Invalid_argument "index out of bounds"]
- if [n] is outside the range 0 to [ArrayLabels.length a - 1]. *)
+ if [n] is outside the range 0 to [Array.length a - 1]. *)
external make : int -> 'a -> 'a array = "caml_make_vect"
-(** [ArrayLabels.make n x] returns a fresh array of length [n],
+(** [Array.make n x] returns a fresh array of length [n],
initialized with [x].
All the elements of this new array are initially
physically equal to [x] (in the sense of the [==] predicate).
size is only [Sys.max_array_length / 2].*)
external create : int -> 'a -> 'a array = "caml_make_vect"
- [@@ocaml.deprecated "Use ArrayLabels.make instead."]
-(** @deprecated [ArrayLabels.create] is an alias for {!ArrayLabels.make}. *)
+ [@@ocaml.deprecated "Use Array.make instead."]
+(** @deprecated [Array.create] is an alias for {!Array.make}. *)
val init : int -> f:(int -> 'a) -> 'a array
-(** [ArrayLabels.init n f] returns a fresh array of length [n],
+(** [Array.init n f] returns a fresh array of length [n],
with element number [i] initialized to the result of [f i].
- In other terms, [ArrayLabels.init n f] tabulates the results of [f]
+ In other terms, [Array.init n f] tabulates the results of [f]
applied to the integers [0] to [n-1].
Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length].
size is only [Sys.max_array_length / 2].*)
val make_matrix : dimx:int -> dimy:int -> 'a -> 'a array array
-(** [ArrayLabels.make_matrix dimx dimy e] returns a two-dimensional array
+(** [Array.make_matrix dimx dimy e] returns a two-dimensional array
(an array of arrays) with first dimension [dimx] and
second dimension [dimy]. All the elements of this new matrix
are initially physically equal to [e].
with the notation [m.(x).(y)].
Raise [Invalid_argument] if [dimx] or [dimy] is negative or
- greater than [Sys.max_array_length].
+ greater than {!Sys.max_array_length}.
If the value of [e] is a floating-point number, then the maximum
size is only [Sys.max_array_length / 2]. *)
val create_matrix : dimx:int -> dimy:int -> 'a -> 'a array array
- [@@ocaml.deprecated "Use ArrayLabels.make_matrix instead."]
-(** @deprecated [ArrayLabels.create_matrix] is an alias for
- {!ArrayLabels.make_matrix}. *)
+ [@@ocaml.deprecated "Use Array.make_matrix instead."]
+(** @deprecated [Array.create_matrix] is an alias for
+ {!Array.make_matrix}. *)
val append : 'a array -> 'a array -> 'a array
-(** [ArrayLabels.append v1 v2] returns a fresh array containing the
+(** [Array.append v1 v2] returns a fresh array containing the
concatenation of the arrays [v1] and [v2]. *)
val concat : 'a array list -> 'a array
-(** Same as [ArrayLabels.append], but concatenates a list of arrays. *)
+(** Same as {!Array.append}, but concatenates a list of arrays. *)
val sub : 'a array -> pos:int -> len:int -> 'a array
-(** [ArrayLabels.sub a start len] returns a fresh array of length [len],
+(** [Array.sub a start len] returns a fresh array of length [len],
containing the elements number [start] to [start + len - 1]
of array [a].
Raise [Invalid_argument "Array.sub"] if [start] and [len] do not
designate a valid subarray of [a]; that is, if
- [start < 0], or [len < 0], or [start + len > ArrayLabels.length a]. *)
+ [start < 0], or [len < 0], or [start + len > Array.length a]. *)
val copy : 'a array -> 'a array
-(** [ArrayLabels.copy a] returns a copy of [a], that is, a fresh array
+(** [Array.copy a] returns a copy of [a], that is, a fresh array
containing the same elements as [a]. *)
val fill : 'a array -> pos:int -> len:int -> 'a -> unit
-(** [ArrayLabels.fill a ofs len x] modifies the array [a] in place,
+(** [Array.fill a ofs len x] modifies the array [a] in place,
storing [x] in elements number [ofs] to [ofs + len - 1].
Raise [Invalid_argument "Array.fill"] if [ofs] and [len] do not
val blit :
src:'a array -> src_pos:int -> dst:'a array -> dst_pos:int -> len:int ->
unit
-(** [ArrayLabels.blit v1 o1 v2 o2 len] copies [len] elements
+(** [Array.blit v1 o1 v2 o2 len] copies [len] elements
from array [v1], starting at element number [o1], to array [v2],
starting at element number [o2]. It works correctly even if
[v1] and [v2] are the same array, and the source and
designate a valid subarray of [v2]. *)
val to_list : 'a array -> 'a list
-(** [ArrayLabels.to_list a] returns the list of all the elements of [a]. *)
+(** [Array.to_list a] returns the list of all the elements of [a]. *)
val of_list : 'a list -> 'a array
-(** [ArrayLabels.of_list l] returns a fresh array containing the elements
+(** [Array.of_list l] returns a fresh array containing the elements
of [l]. *)
val iter : f:('a -> unit) -> 'a array -> unit
-(** [ArrayLabels.iter f a] applies function [f] in turn to all
+(** [Array.iter f a] applies function [f] in turn to all
the elements of [a]. It is equivalent to
- [f a.(0); f a.(1); ...; f a.(ArrayLabels.length a - 1); ()]. *)
+ [f a.(0); f a.(1); ...; f a.(Array.length a - 1); ()]. *)
val map : f:('a -> 'b) -> 'a array -> 'b array
-(** [ArrayLabels.map f a] applies function [f] to all the elements of [a],
+(** [Array.map f a] applies function [f] to all the elements of [a],
and builds an array with the results returned by [f]:
- [[| f a.(0); f a.(1); ...; f a.(ArrayLabels.length a - 1) |]]. *)
+ [[| f a.(0); f a.(1); ...; f a.(Array.length a - 1) |]]. *)
val iteri : f:(int -> 'a -> unit) -> 'a array -> unit
-(** Same as {!ArrayLabels.iter}, but the
+(** Same as {!Array.iter}, but the
function is applied to the index of the element as first argument,
and the element itself as second argument. *)
val mapi : f:(int -> 'a -> 'b) -> 'a array -> 'b array
-(** Same as {!ArrayLabels.map}, but the
+(** Same as {!Array.map}, but the
function is applied to the index of the element as first argument,
and the element itself as second argument. *)
val fold_left : f:('a -> 'b -> 'a) -> init:'a -> 'b array -> 'a
-(** [ArrayLabels.fold_left f x a] computes
+(** [Array.fold_left f x a] computes
[f (... (f (f x a.(0)) a.(1)) ...) a.(n-1)],
where [n] is the length of the array [a]. *)
val fold_right : f:('b -> 'a -> 'a) -> 'b array -> init:'a -> 'a
-(** [ArrayLabels.fold_right f a x] computes
+(** [Array.fold_right f a x] computes
[f a.(0) (f a.(1) ( ... (f a.(n-1) x) ...))],
where [n] is the length of the array [a]. *)
+
+(** {6 Iterators on two arrays} *)
+
+
+val iter2 : f:('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.
+ @since 4.05.0 *)
+
+val map2 : f:('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.
+ @since 4.05.0 *)
+
+
+(** {6 Array scanning} *)
+
+
val exists : f:('a -> bool) -> 'a array -> bool
-(** [ArrayLabels.exists p [|a1; ...; an|]] checks if at least one element of
+(** [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 for_all : f:('a -> bool) -> 'a array -> bool
-(** [ArrayLabels.for_all p [|a1; ...; an|]] checks if all elements of the array
+(** [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 mem : 'a -> set:'a array -> bool
(** [mem x a] is true if and only if [x] is equal
- to an element of [a]. *)
+ to an element of [a].
+ @since 4.03.0 *)
val memq : 'a -> set:'a array -> bool
-(** Same as {!ArrayLabels.mem}, but uses physical equality instead of structural
- equality to compare list elements. *)
+(** Same as {!Array.mem}, but uses physical equality instead of structural
+ equality to compare list elements.
+ @since 4.03.0 *)
external create_float: int -> float array = "caml_make_float_vect"
-(** [ArrayLabels.create_float n] returns a fresh float array of length [n],
+(** [Array.create_float n] returns a fresh float array of length [n],
with uninitialized data.
@since 4.03 *)
val make_float: int -> float array
- [@@ocaml.deprecated "Use ArrayLabels.create_float instead."]
-(** @deprecated [ArrayLabels.make_float] is an alias for
- {!ArrayLabels.create_float}. *)
+ [@@ocaml.deprecated "Use Array.create_float instead."]
+(** @deprecated [Array.make_float] is an alias for
+ {!Array.create_float}. *)
(** {6 Sorting} *)
and a negative integer if the first is smaller (see below for a
complete specification). For example, {!Pervasives.compare} is
a suitable comparison function, provided there are no floating-point
- NaN values in the data. After calling [ArrayLabels.sort], the
+ NaN values in the data. After calling [Array.sort], the
array is sorted in place in increasing order.
- [ArrayLabels.sort] is guaranteed to run in constant heap space
+ [Array.sort] is guaranteed to run in constant heap space
and (at most) logarithmic stack space.
The current implementation uses Heap Sort. It runs in constant
- [cmp x y] > 0 if and only if [cmp y x] < 0
- if [cmp x y] >= 0 and [cmp y z] >= 0 then [cmp x z] >= 0
- When [ArrayLabels.sort] returns, [a] contains the same elements as before,
+ When [Array.sort] returns, [a] contains the same elements as before,
reordered in such a way that for all i and j valid indices of [a] :
- [cmp a.(i) a.(j)] >= 0 if and only if i >= j
*)
val stable_sort : cmp:('a -> 'a -> int) -> 'a array -> unit
-(** Same as {!ArrayLabels.sort}, but the sorting algorithm is stable (i.e.
+(** Same as {!Array.sort}, but the sorting algorithm is stable (i.e.
elements that compare equal are kept in their original order) and
not guaranteed to run in constant heap space.
The current implementation uses Merge Sort. It uses [n/2]
words of heap space, where [n] is the length of the array.
- It is usually faster than the current implementation of {!ArrayLabels.sort}.
+ It is usually faster than the current implementation of {!Array.sort}.
*)
val fast_sort : cmp:('a -> 'a -> int) -> 'a array -> unit
-(** Same as {!ArrayLabels.sort} or {!ArrayLabels.stable_sort}, whichever is
+(** Same as {!Array.sort} or {!Array.stable_sort}, whichever is
faster on typical input.
*)
end else
if previous = '\\' then add_char b previous in
subst ' ' 0
+
+let truncate b len =
+ if len < 0 || len > length b then
+ invalid_arg "Buffer.truncate"
+ else
+ b.position <- len
val output_buffer : out_channel -> t -> unit
(** [output_buffer oc b] writes the current contents of buffer [b]
on the output channel [oc]. *)
+
+val truncate : t -> int -> unit
+(** [truncate b len] truncates the length of [b] to [len]
+ Note: the internal byte sequence is not shortened.
+ Raise [Invalid_argument] if [len < 0] or [len > length b].
+ @since 4.05.0 *)
let sub_string b ofs len = unsafe_to_string (sub b ofs len)
+(* addition with an overflow check *)
+let (++) a b =
+ let c = a + b in
+ match a < 0, b < 0, c < 0 with
+ | true , true , false
+ | false, false, true -> invalid_arg "Bytes.extend" (* overflow *)
+ | _ -> c
+
let extend s left right =
- let len = length s + left + right in
+ let len = length s ++ left ++ right in
let r = create len in
let (srcoff, dstoff) = if left < 0 then -left, 0 else 0, left in
let cpylen = min (length s - srcoff) (len - dstoff) in
let concat sep = function
[] -> empty
| l -> let seplen = length sep in
- unsafe_blits
+ unsafe_blits
(create (sum_lengths 0 seplen l))
0 sep seplen l
(* duplicated in string.ml *)
let index s c = index_rec s (length s) 0 c
+(* duplicated in string.ml *)
+let rec index_rec_opt s lim i c =
+ if i >= lim then None else
+ if unsafe_get s i = c then Some i else index_rec_opt s lim (i + 1) c
+
+(* duplicated in string.ml *)
+let index_opt s c = index_rec_opt 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 index_from_opt s i c =
+ let l = length s in
+ if i < 0 || i > l then invalid_arg "String.index_from_opt / Bytes.index_from_opt" else
+ index_rec_opt s l i c
+
(* duplicated in string.ml *)
let rec rindex_rec s i c =
if i < 0 then raise Not_found else
else
rindex_rec s i c
+(* duplicated in string.ml *)
+let rec rindex_rec_opt s i c =
+ if i < 0 then None else
+ if unsafe_get s i = c then Some i else rindex_rec_opt s (i - 1) c
+
+(* duplicated in string.ml *)
+let rindex_opt s c = rindex_rec_opt s (length s - 1) c
+
+(* duplicated in string.ml *)
+let rindex_from_opt s i c =
+ if i < -1 || i >= length s then
+ invalid_arg "String.rindex_from_opt / Bytes.rindex_from_opt"
+ else
+ rindex_rec_opt s i c
+
(* duplicated in string.ml *)
let contains_from s i c =
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]. *)
+ Raise [Invalid_argument] if [n] is not a valid index in [s]. *)
external set : bytes -> int -> char -> unit = "%bytes_safe_set"
(** [set s n c] modifies [s] in place, replacing the byte at index [n]
Raise [Not_found] if [c] does not occur in [s]. *)
+val index_opt: bytes -> char -> int option
+(** [index_opt s c] returns the index of the first occurrence of byte [c]
+ in [s] or [None] if [c] does not occur in [s].
+ @since 4.05 *)
+
val rindex : bytes -> char -> int
(** [rindex s c] returns the index of the last occurrence of byte [c]
in [s].
Raise [Not_found] if [c] does not occur in [s]. *)
+val rindex_opt: bytes -> char -> int option
+(** [rindex_opt s c] returns the index of the last occurrence of byte [c]
+ in [s] or [None] if [c] does not occur in [s].
+ @since 4.05 *)
+
val index_from : bytes -> int -> char -> int
(** [index_from s i c] returns the index of the first occurrence of
byte [c] in [s] after position [i]. [Bytes.index s c] is
Raise [Invalid_argument] if [i] is not a valid position in [s].
Raise [Not_found] if [c] does not occur in [s] after position [i]. *)
+val index_from_opt: bytes -> int -> char -> int option
+(** [index_from _opts i c] returns the index of the first occurrence of
+ byte [c] in [s] after position [i] or [None] if [c] does not occur in [s] after position [i].
+ [Bytes.index_opt s c] is equivalent to [Bytes.index_from_opt s 0 c].
+
+ Raise [Invalid_argument] if [i] is not a valid position in [s].
+ @since 4.05 *)
+
val rindex_from : bytes -> int -> char -> int
(** [rindex_from s i c] returns the index of the last occurrence of
byte [c] in [s] before position [i+1]. [rindex s c] is equivalent
Raise [Invalid_argument] if [i+1] is not a valid position in [s].
Raise [Not_found] if [c] does not occur in [s] before position [i+1]. *)
+val rindex_from_opt: bytes -> int -> char -> int option
+(** [rindex_from_opt s i c] returns the index of the last occurrence
+ of byte [c] in [s] before position [i+1] or [None] if [c] does not
+ occur in [s] before position [i+1]. [rindex_opt s c] is equivalent to
+ [rindex_from s (Bytes.length s - 1) c].
+
+ Raise [Invalid_argument] if [i+1] is not a valid position in [s].
+ @since 4.05 *)
+
val contains : bytes -> char -> bool
(** [contains s c] tests if byte [c] appears in [s]. *)
The caller may not mutate [s] while the string is borrowed (it has
temporarily given up ownership). This affects concurrent programs,
- but also higher-order functions: if [String.length] returned
+ but also higher-order functions: if {!String.length} returned
a closure to be called later, [s] should not be mutated until this
closure is fully applied and returns ownership.
*)
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]. *)
+ Raise [Invalid_argument] if [n] is not a valid index in [s]. *)
external set : bytes -> int -> char -> unit = "%bytes_safe_set"
val sub_string : bytes -> int -> int -> string
(** Same as [sub] but return a string instead of a byte sequence. *)
+val extend : bytes -> left:int -> right:int -> bytes
+(** [extend s left right] returns a new byte sequence that contains
+ the bytes of [s], with [left] uninitialized bytes prepended and
+ [right] uninitialized bytes appended to it. If [left] or [right]
+ is negative, then bytes are removed (instead of appended) from
+ the corresponding side of [s].
+
+ Raise [Invalid_argument] if the result length is negative or
+ longer than {!Sys.max_string_length} bytes.
+ @since 4.05.0 *)
+
val fill : bytes -> pos:int -> len:int -> char -> unit
(** [fill s start len c] modifies [s] in place, replacing [len]
characters with [c], starting at [start].
designate a valid range of [src], or if [dstoff] and [len]
do not designate a valid range of [dst]. *)
+val blit_string :
+ src:string -> src_pos:int -> dst:bytes -> dst_pos:int -> len:int
+ -> unit
+(** [blit src srcoff dst dstoff len] copies [len] bytes from string
+ [src], starting at index [srcoff], to byte sequence [dst],
+ starting at index [dstoff].
+
+ Raise [Invalid_argument] if [srcoff] and [len] do not
+ designate a valid range of [src], or if [dstoff] and [len]
+ do not designate a valid range of [dst].
+ @since 4.05.0 *)
+
val concat : sep:bytes -> bytes list -> bytes
(** [concat sep sl] concatenates the list of byte sequences [sl],
inserting the separator byte sequence [sep] between each, and
returns the result as a new byte sequence. *)
+val cat : bytes -> bytes -> bytes
+(** [cat s1 s2] concatenates [s1] and [s2] and returns the result
+ as new byte sequence.
+
+ Raise [Invalid_argument] if the result is longer than
+ {!Sys.max_string_length} bytes.
+ @since 4.05.0 *)
+
val iter : f:(char -> unit) -> bytes -> unit
(** [iter f s] applies function [f] in turn to all the bytes of [s].
It is equivalent to [f (get s 0); f (get s 1); ...; f (get s
Raise [Not_found] if [c] does not occur in [s]. *)
+val index_opt: bytes -> char -> int option
+(** [index_opt s c] returns the index of the first occurrence of byte [c]
+ in [s] or [None] if [c] does not occur in [s].
+ @since 4.05 *)
+
val rindex : bytes -> char -> int
(** [rindex s c] returns the index of the last occurrence of byte [c]
in [s].
Raise [Not_found] if [c] does not occur in [s]. *)
+val rindex_opt: bytes -> char -> int option
+(** [rindex_opt s c] returns the index of the last occurrence of byte [c]
+ in [s] or [None] if [c] does not occur in [s].
+ @since 4.05 *)
+
val index_from : bytes -> int -> char -> int
(** [index_from s i c] returns the index of the first occurrence of
byte [c] in [s] after position [i]. [Bytes.index s c] is
Raise [Invalid_argument] if [i] is not a valid position in [s].
Raise [Not_found] if [c] does not occur in [s] after position [i]. *)
+val index_from_opt: bytes -> int -> char -> int option
+(** [index_from _opts i c] returns the index of the first occurrence of
+ byte [c] in [s] after position [i] or [None] if [c] does not occur in [s] after position [i].
+ [Bytes.index_opt s c] is equivalent to [Bytes.index_from_opt s 0 c].
+
+ Raise [Invalid_argument] if [i] is not a valid position in [s].
+ @since 4.05 *)
+
val rindex_from : bytes -> int -> char -> int
(** [rindex_from s i c] returns the index of the last occurrence of
byte [c] in [s] before position [i+1]. [rindex s c] is equivalent
Raise [Invalid_argument] if [i+1] is not a valid position in [s].
Raise [Not_found] if [c] does not occur in [s] before position [i+1]. *)
+val rindex_from_opt: bytes -> int -> char -> int option
+(** [rindex_from_opt s i c] returns the index of the last occurrence
+ of byte [c] in [s] before position [i+1] or [None] if [c] does not
+ occur in [s] before position [i+1]. [rindex_opt s c] is equivalent to
+ [rindex_from s (Bytes.length s - 1) c].
+
+ Raise [Invalid_argument] if [i+1] is not a valid position in [s].
+ @since 4.05 *)
+
val contains : bytes -> char -> bool
(** [contains s c] tests if byte [c] appears in [s]. *)
position in [s]. *)
val uppercase : bytes -> bytes
+ [@@ocaml.deprecated "Use Bytes.uppercase_ascii instead."]
(** Return a copy of the argument, with all lowercase letters
- translated to uppercase, including accented letters of the ISO
- Latin-1 (8859-1) character set. *)
+ translated to uppercase, including accented letters of the ISO
+ Latin-1 (8859-1) character set.
+ @deprecated Functions operating on Latin-1 character set are deprecated. *)
val lowercase : bytes -> bytes
+ [@@ocaml.deprecated "Use Bytes.lowercase_ascii instead."]
(** Return a copy of the argument, with all uppercase letters
- translated to lowercase, including accented letters of the ISO
- Latin-1 (8859-1) character set. *)
+ translated to lowercase, including accented letters of the ISO
+ Latin-1 (8859-1) character set.
+ @deprecated Functions operating on Latin-1 character set are deprecated. *)
val capitalize : bytes -> bytes
-(** Return a copy of the argument, with the first byte set to
- uppercase. *)
+ [@@ocaml.deprecated "Use Bytes.capitalize_ascii instead."]
+(** Return a copy of the argument, with the first character set to uppercase,
+ using the ISO Latin-1 (8859-1) character set..
+ @deprecated Functions operating on Latin-1 character set are deprecated. *)
val uncapitalize : bytes -> bytes
-(** Return a copy of the argument, with the first byte set to
- lowercase. *)
+ [@@ocaml.deprecated "Use Bytes.uncapitalize_ascii instead."]
+(** Return a copy of the argument, with the first character set to lowercase,
+ using the ISO Latin-1 (8859-1) character set..
+ @deprecated Functions operating on Latin-1 character set are deprecated. *)
+
+val uppercase_ascii : bytes -> bytes
+(** Return a copy of the argument, with all lowercase letters
+ translated to uppercase, using the US-ASCII character set.
+ @since 4.05.0 *)
+
+val lowercase_ascii : bytes -> bytes
+(** Return a copy of the argument, with all uppercase letters
+ translated to lowercase, using the US-ASCII character set.
+ @since 4.05.0 *)
+
+val capitalize_ascii : bytes -> bytes
+(** Return a copy of the argument, with the first character set to uppercase,
+ using the US-ASCII character set.
+ @since 4.05.0 *)
+
+val uncapitalize_ascii : bytes -> bytes
+(** Return a copy of the argument, with the first character set to lowercase,
+ using the US-ASCII character set.
+ @since 4.05.0 *)
type t = bytes
(** An alias for the type of byte sequences. *)
this function [compare] allows the module [Bytes] to be passed as
argument to the functors {!Set.Make} and {!Map.Make}. *)
+val equal: t -> t -> bool
+(** The equality function for byte sequences.
+ @since 4.05.0 *)
+
(**/**)
(* The following is for system use only. Do not call directly. *)
Char.unsafe_chr (n + if n < 10 then Char.code '0' else (Char.code 'a' - 10))
let to_hex d =
+ if String.length d <> 16 then invalid_arg "Digest.to_hex";
let result = Bytes.create 32 in
for i = 0 to 15 do
let x = Char.code d.[i] in
Bytes.unsafe_to_string result
let from_hex s =
- if String.length s <> 32 then raise (Invalid_argument "Digest.from_hex");
+ if String.length s <> 32 then invalid_arg "Digest.from_hex";
let digit c =
match c with
| '0'..'9' -> Char.code c - Char.code '0'
(** Read a digest from the given input channel. *)
val to_hex : t -> string
-(** Return the printable hexadecimal representation of the given digest. *)
+(** Return the printable hexadecimal representation of the given digest.
+ Raise [Invalid_argument] if the argument is not exactly 16 bytes.
+ *)
val from_hex : string -> t
(** Convert a hexadecimal representation back into the corresponding digest.
(* TODO inline 3 iterations *)
find_rec key hkey (h.data.(key_index h hkey))
+ let rec find_rec_opt key hkey = function
+ | Empty ->
+ None
+ | Cons(hk, c, rest) when hkey = hk ->
+ begin match H.equal c key with
+ | ETrue ->
+ begin match H.get_data c with
+ | None ->
+ (* This case is not impossible because the gc can run between
+ H.equal and H.get_data *)
+ find_rec_opt key hkey rest
+ | Some _ as d -> d
+ end
+ | EFalse -> find_rec_opt key hkey rest
+ | EDead ->
+ find_rec_opt key hkey rest
+ end
+ | Cons(_, _, rest) ->
+ find_rec_opt key hkey rest
+
+ let find_opt h key =
+ let hkey = H.hash h.seed key in
+ (* TODO inline 3 iterations *)
+ find_rec_opt key hkey (h.data.(key_index h hkey))
+
let find_all h key =
let hkey = H.hash h.seed key in
let rec find_in_bucket = function
Ephemerons are defined in a language agnostic way in this paper:
B. Hayes, Ephemerons: a New Finalization Mechanism, OOPSLA'9
+ @since 4.03.0
*)
module type S = sig
(** [Ephemeron.K1.get_key_copy eph] returns [None] if the key of [eph] is
empty, [Some x] (where [x] is a (shallow) copy of the key) if
it is full. This function has the same GC friendliness as {!Weak.get_copy}
+
+ If the element is a custom block it is not copied.
*)
val set_key: ('k,'d) t -> 'k -> unit
val blit_key : ('k,_) t -> ('k,_) t -> unit
(** [Ephemeron.K1.blit_key eph1 eph2] sets the key of [eph2] with
- the key of [eph1]. Contrary to using [Ephemeron.K1.get_key]
- followed by [Ephemeron.K1.set_key] or [Ephemeon.K1.unset_key]
+ the key of [eph1]. Contrary to using {!Ephemeron.K1.get_key}
+ followed by {!Ephemeron.K1.set_key} or {!Ephemeron.K1.unset_key}
this function does not prevent the incremental GC from erasing
the value in its current cycle. *)
(** [Ephemeron.K1.get_data_copy eph] returns [None] if the data of [eph] is
empty, [Some x] (where [x] is a (shallow) copy of the data) if
it is full. This function has the same GC friendliness as {!Weak.get_copy}
+
+ If the element is a custom block it is not copied.
*)
val set_data: ('k,'d) t -> 'd -> unit
*)
val unset_data: ('k,'d) t -> unit
- (** [Ephemeron.K1.unset_key eph el] sets the key of [eph] to be an
+ (** [Ephemeron.K1.unset_data eph el] sets the key of [eph] to be an
empty key. The ephemeron starts behaving like a weak pointer.
*)
val blit_data : (_,'d) t -> (_,'d) t -> unit
(** [Ephemeron.K1.blit_data eph1 eph2] sets the data of [eph2] with
- the data of [eph1]. Contrary to using [Ephemeron.K1.get_data]
- followed by [Ephemeron.K1.set_data] or [Ephemeon.K1.unset_data]
+ the data of [eph1]. Contrary to using {!Ephemeron.K1.get_data}
+ followed by {!Ephemeron.K1.set_data} or {!Ephemeron.K1.unset_data}
this function does not prevent the incremental GC from erasing
the value in its current cycle. *)
(** Same as {!Ephemeron.K1.get_key_copy} *)
val set_key2: ('k1,'k2,'d) t -> 'k2 -> unit
- (** Same as {!Ephemeron.K1.get_key} *)
+ (** Same as {!Ephemeron.K1.set_key} *)
val unset_key2: ('k1,'k2,'d) t -> unit
(** Same as {!Ephemeron.K1.unset_key} *)
(** [get_key cont] returns the keys if they are all alive *)
val get_data: 'a container -> 'a option
- (** [get_data cont] return the data if it is alive *)
+ (** [get_data cont] returns the data if it is alive *)
val set_key_data: 'a container -> t -> 'a -> unit
- (** [set_key_data cont] modify the key and data *)
+ (** [set_key_data cont] modifies the key and data *)
val check_key: 'a container -> bool
(** [check_key cont] checks if all the keys contained in the data
out_flush : unit -> unit;
out_newline : unit -> unit;
out_spaces : int -> unit;
-}
+} (** @since 4.01.0 *)
val set_formatter_out_functions : formatter_out_functions -> unit
(** [set_formatter_out_functions f]
application at hand). The two functions [f.out_spaces] and [f.out_newline]
are normally connected to [f.out_string] and [f.out_flush]: respective
default values for [f.out_space] and [f.out_newline] are
- [f.out_string (String.make n ' ') 0 n] and [f.out_string "\n" 0 1]. *)
+ [f.out_string (String.make n ' ') 0 n] and [f.out_string "\n" 0 1].
+ @since 4.01.0 *)
val get_formatter_out_functions : unit -> formatter_out_functions
(** Return the current output functions of the pretty-printer,
including line splitting and indentation functions. Useful to record the
- current setting and restore it afterwards. *)
+ current setting and restore it afterwards.
+ @since 4.01.0 *)
(** {6:tagsmeaning Changing the meaning of printing semantic tags} *)
margin, maximum indentation limit, maximum number of boxes
simultaneously opened, ellipsis, and so on, are specific to
each pretty-printer and may be fixed independently.
- Given a [Pervasives.out_channel] output channel [oc], a new formatter
+ Given a {!Pervasives.out_channel} output channel [oc], a new formatter
writing to that channel is simply obtained by calling
[formatter_of_out_channel oc].
Alternatively, the [make_formatter] function allocates a new
(string -> int -> int -> unit) -> (unit -> unit) -> formatter
(** [make_formatter out flush] returns a new formatter that writes according
to the output function [out], and the flushing function [flush]. For
- instance, a formatter to the [Pervasives.out_channel] [oc] is returned by
+ instance, a formatter to the {!Pervasives.out_channel} [oc] is returned by
[make_formatter (Pervasives.output oc) (fun () -> Pervasives.flush oc)]. *)
(** {6 Basic functions to use with formatters} *)
val pp_set_formatter_out_functions :
formatter -> formatter_out_functions -> unit
+(** @since 4.01.0 *)
val pp_get_formatter_out_functions :
formatter -> unit -> formatter_out_functions
(** These functions are the basic ones: usual functions
operating on the standard formatter are defined via partial
evaluation of these primitives. For instance,
- [print_string] is equal to [pp_print_string std_formatter]. *)
+ [print_string] is equal to [pp_print_string std_formatter].
+ @since 4.01.0 *)
val pp_flush_formatter : formatter -> unit
(** [pp_flush_formatter fmt] flushes [fmt]'s internal queue, ensuring that all
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. *)
+ {!pp_print_flush} instead.
+ @since 4.04.0 *)
(** {6 Convenience formatting functions.} *)
The format [fmt] is a character string which contains three types of
objects: plain characters and conversion specifications as specified in
- the [Printf] module, and pretty-printing indications specific to the
+ the {!Printf} module, and pretty-printing indications specific to the
[Format] module.
The pretty-printing indication characters are introduced by
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]
+ = "caml_gc_minor_words" "caml_gc_minor_words_unboxed"
external get : unit -> control = "caml_gc_get"
external set : control -> unit = "caml_gc_set"
external minor : unit -> unit = "caml_gc_minor"
external major : unit -> unit = "caml_gc_major"
external full_major : unit -> unit = "caml_gc_full_major"
external compact : unit -> unit = "caml_gc_compaction"
-external get_minor_free : unit -> int = "caml_get_minor_free" [@@noalloc]
+external get_minor_free : unit -> int = "caml_get_minor_free"
external get_bucket : int -> int = "caml_get_major_bucket" [@@noalloc]
external get_credit : unit -> int = "caml_get_major_credit" [@@noalloc]
external huge_fallback_count : unit -> int = "caml_gc_huge_fallback_count"
is as fast as [quick_stat]. *)
external minor_words : unit -> (float [@unboxed])
- = "caml_gc_minor_words" "caml_gc_minor_words_unboxed" [@@noalloc]
+ = "caml_gc_minor_words" "caml_gc_minor_words_unboxed"
(** 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.
started. It is returned as a [float] to avoid overflow problems
with [int] on 32-bit machines. *)
-external get_minor_free : unit -> int = "caml_get_minor_free" [@@noalloc]
+external get_minor_free : unit -> int = "caml_get_minor_free"
(** Return the current size of the free space inside the minor heap.
@since 4.03.0 *)
belongs to this list, and as [Ident s] otherwise.
A special character [s] is returned as [Kwd s] if [s]
belongs to this list, and cause a lexical error (exception
- [Stream.Error] with the offending lexeme as its parameter) otherwise.
+ {!Stream.Error} with the offending lexeme as its parameter) otherwise.
Blanks and newlines are skipped. Comments delimited by [(*] and [*)]
- are skipped as well, and can be nested. A [Stream.Failure] exception
+ are skipped as well, and can be nested. A {!Stream.Failure} exception
is raised if end of stream is unexpectedly reached.*)
| Cons{key=k3; data=d3; next=next3} ->
if compare key k3 = 0 then d3 else find_rec key next3
+let rec find_rec_opt key = function
+ | Empty ->
+ None
+ | Cons{key=k; data; next} ->
+ if compare key k = 0 then Some data else find_rec_opt key next
+
+let find_opt h key =
+ match h.data.(key_index h key) with
+ | Empty -> None
+ | Cons{key=k1; data=d1; next=next1} ->
+ if compare key k1 = 0 then Some d1 else
+ match next1 with
+ | Empty -> None
+ | Cons{key=k2; data=d2; next=next2} ->
+ if compare key k2 = 0 then Some d2 else
+ match next2 with
+ | Empty -> None
+ | Cons{key=k3; data=d3; next=next3} ->
+ if compare key k3 = 0 then Some d3 else find_rec_opt key next3
+
let find_all h key =
let rec find_in_bucket = function
| Empty ->
val add: 'a t -> key -> 'a -> unit
val remove: 'a t -> key -> unit
val find: 'a t -> key -> 'a
+ val find_opt: 'a t -> key -> 'a option
val find_all: 'a t -> key -> 'a list
val replace : 'a t -> key -> 'a -> unit
val mem : 'a t -> key -> bool
val add : 'a t -> key -> 'a -> unit
val remove : 'a t -> key -> unit
val find : 'a t -> key -> 'a
+ val find_opt: 'a t -> key -> 'a option
val find_all : 'a t -> key -> 'a list
val replace : 'a t -> key -> 'a -> unit
val mem : 'a t -> key -> bool
| Cons{key=k3; data=d3; next=next3} ->
if H.equal key k3 then d3 else find_rec key next3
+ let rec find_rec_opt key = function
+ | Empty ->
+ None
+ | Cons{key=k; data; next} ->
+ if H.equal key k then Some data else find_rec_opt key next
+
+ let find_opt h key =
+ match h.data.(key_index h key) with
+ | Empty -> None
+ | Cons{key=k1; data=d1; next=next1} ->
+ if H.equal key k1 then Some d1 else
+ match next1 with
+ | Empty -> None
+ | Cons{key=k2; data=d2; next=next2} ->
+ if H.equal key k2 then Some d2 else
+ match next2 with
+ | Empty -> None
+ | Cons{key=k3; data=d3; next=next3} ->
+ if H.equal key k3 then Some d3 else find_rec_opt key next3
+
let find_all h key =
let rec find_in_bucket = function
| Empty ->
(** [Hashtbl.find tbl x] returns the current binding of [x] in [tbl],
or raises [Not_found] if no such binding exists. *)
+val find_opt : ('a, 'b) t -> 'a -> 'b option
+(** [Hashtbl.find_opt tbl x] returns the current binding of [x] in [tbl],
+ or [None] if no such binding exists.
+ @since 4.05 *)
+
val find_all : ('a, 'b) t -> 'a -> 'b list
(** [Hashtbl.find_all tbl x] returns the list of all data
associated with [x] in [tbl].
val is_randomized : unit -> bool
(** return if the tables are currently created in randomized mode by default
- @since 4.02.0 *)
+ @since 4.03.0 *)
+(** @since 4.00.0 *)
type statistics = {
num_bindings: int;
(** Number of bindings present in the table.
type 'a t
val create : int -> 'a t
val clear : 'a t -> unit
- val reset : 'a t -> unit
+ val reset : 'a t -> unit (** @since 4.00.0 *)
+
val copy : 'a t -> 'a t
val add : 'a t -> key -> 'a -> unit
val remove : 'a t -> key -> unit
val find : 'a t -> key -> 'a
+ val find_opt : 'a t -> key -> 'a option
+ (** @since 4.05.0 *)
+
val find_all : 'a t -> key -> 'a list
val replace : 'a t -> key -> 'a -> unit
val mem : 'a t -> key -> bool
val iter : (key -> 'a -> unit) -> 'a t -> unit
val filter_map_inplace: (key -> 'a -> 'a option) -> 'a t -> unit
+ (** @since 4.03.0 *)
+
val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
val length : 'a t -> int
- val stats: 'a t -> statistics
+ val stats: 'a t -> statistics (** @since 4.00.0 *)
end
(** The output signature of the functor {!Hashtbl.Make}. *)
val add : 'a t -> key -> 'a -> unit
val remove : 'a t -> key -> unit
val find : 'a t -> key -> 'a
+ val find_opt : 'a t -> key -> 'a option (** @since 4.05.0 *)
+
val find_all : 'a t -> key -> 'a list
val replace : 'a t -> key -> 'a -> unit
val mem : 'a t -> key -> bool
val iter : (key -> 'a -> unit) -> 'a t -> unit
val filter_map_inplace: (key -> 'a -> 'a option) -> 'a t -> unit
+ (** @since 4.03.0 *)
+
val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
val length : 'a t -> int
val stats: 'a t -> statistics
external of_string : string -> int32 = "caml_int32_of_string"
+let of_string_opt s =
+ (* TODO: expose a non-raising primitive directly. *)
+ try Some (of_string s)
+ with Failure _ -> None
+
type t = int32
let compare (x: t) (y: t) = Pervasives.compare x y
a valid representation of an integer, or if the integer represented
exceeds the range of integers representable in type [int32]. *)
+val of_string_opt: string -> int32 option
+(** Same as [of_string], but return [None] instead of raising.
+ @since 4.05 *)
+
+
val to_string : int32 -> string
(** Return the string representation of its argument, in signed decimal. *)
external of_string : string -> int64 = "caml_int64_of_string"
+let of_string_opt s =
+ (* TODO: expose a non-raising primitive directly. *)
+ try Some (of_string s)
+ with Failure _ -> None
+
+
+
external bits_of_float : float -> int64
= "caml_int64_bits_of_float" "caml_int64_bits_of_float_unboxed"
[@@unboxed] [@@noalloc]
a valid representation of an integer, or if the integer represented
exceeds the range of integers representable in type [int64]. *)
+val of_string_opt: string -> int64 option
+(** Same as [of_string], but return [None] instead of raising.
+ @since 4.05 *)
+
val to_string : int64 -> string
(** Return the string representation of its argument, in decimal. *)
If [x] has already been forced, [Lazy.force x] returns the
same value again without recomputing it. If it raised an exception,
the same exception is raised again.
- Raise [Undefined] if the forcing of [x] tries to force [x] itself
+ Raise {!Undefined} if the forcing of [x] tries to force [x] itself
recursively.
*)
(** [force_val x] forces the suspension [x] and returns its
result. If [x] has already been forced, [force_val x]
returns the same value again without recomputing it.
- Raise [Undefined] if the forcing of [x] tries to force [x] itself
+ Raise {!Undefined} if the forcing of [x] tries to force [x] itself
recursively.
If the computation of [x] raises an exception, it is unspecified
- whether [force_val x] raises the same exception or [Undefined].
+ whether [force_val x] raises the same exception or {!Undefined}.
*)
val from_fun : (unit -> 'a) -> 'a t
| a::l -> if n = 0 then a else nth_aux l (n-1)
in nth_aux l n
+let nth_opt l n =
+ if n < 0 then invalid_arg "List.nth" else
+ let rec nth_aux l n =
+ match l with
+ | [] -> None
+ | a::l -> if n = 0 then Some a else nth_aux l (n-1)
+ in nth_aux l n
+
let append = (@)
let rec rev_append l1 l2 =
[] -> raise Not_found
| (a,b)::l -> if compare a x = 0 then b else assoc x l
+let rec assoc_opt x = function
+ [] -> None
+ | (a,b)::l -> if compare a x = 0 then Some b else assoc_opt x l
+
let rec assq x = function
[] -> raise Not_found
| (a,b)::l -> if a == x then b else assq x l
+let rec assq_opt x = function
+ [] -> None
+ | (a,b)::l -> if a == x then Some b else assq_opt x l
+
let rec mem_assoc x = function
| [] -> false
| (a, _) :: l -> compare a x = 0 || mem_assoc x l
| [] -> raise Not_found
| x :: l -> if p x then x else find p l
+let rec find_opt p = function
+ | [] -> None
+ | x :: l -> if p x then Some x else find_opt p l
+
let find_all p =
let rec find accu = function
| [] -> rev accu
in
let len = length l in
if len < 2 then l else sort len l
+
+let rec compare_lengths l1 l2 =
+ match l1, l2 with
+ | [], [] -> 0
+ | [], _ -> -1
+ | _, [] -> 1
+ | _ :: l1, _ :: l2 -> compare_lengths l1 l2
+;;
+
+let rec compare_length_with l n =
+ match l, n with
+ | [], 0 -> 0
+ | [], _ -> if n > 0 then -1 else 1
+ | _, 0 -> 1
+ | _ :: l, n -> compare_length_with l (n-1)
+;;
val length : 'a list -> int
(** Return the length (number of elements) of the given list. *)
+val compare_lengths : 'a list -> 'b list -> int
+(** Compare the lengths of two lists. [compare_lengths l1 l2] is
+ equivalent to [compare (length l1) (length l2)], except that
+ the computation stops after itering on the shortest list.
+ @since 4.05.0
+ *)
+
+val compare_length_with : 'a list -> int -> int
+(** Compare the length of a list to an integer. [compare_length_with l n] is
+ equivalent to [compare (length l) n], except that
+ the computation stops after at most [n] iterations on the list.
+ @since 4.05.0
+*)
+
val cons : 'a -> 'a list -> 'a list
(** [cons x xs] is [x :: xs]
@since 4.03.0
val tl : 'a list -> 'a list
(** Return the given list without its first element. Raise
- [Failure "tl"] if the list is empty. *)
+ [Failure "tl"] if the list is empty. *)
-val nth : 'a list -> int -> 'a
+val nth: 'a list -> int -> 'a
(** Return the [n]-th element of the given list.
The first element (head of the list) is at position 0.
Raise [Failure "nth"] if the list is too short.
Raise [Invalid_argument "List.nth"] if [n] is negative. *)
+val nth_opt: 'a list -> int -> 'a option
+(** Return the [n]-th element of the given list.
+ The first element (head of the list) is at position 0.
+ Return [None] if the list is too short.
+ Raise [Invalid_argument "List.nth"] if [n] is negative.
+ @since 4.05
+*)
+
val rev : 'a list -> 'a list
(** List reversal. *)
Raise [Not_found] if there is no value that satisfies [p] in the
list [l]. *)
+val find_opt: ('a -> bool) -> 'a list -> 'a option
+(** [find_opt p l] returns the first element of the list [l] that
+ satisfies the predicate [p], or [None] if there is no value that
+ satisfies [p] in the list [l].
+ @since 4.05 *)
+
val filter : ('a -> bool) -> 'a list -> 'a list
(** [filter p l] returns all the elements of the list [l]
that satisfy the predicate [p]. The order of the elements
Raise [Not_found] if there is no value associated with [a] in the
list [l]. *)
+val assoc_opt: 'a -> ('a * 'b) list -> 'b option
+(** [assoc_opt a l] returns the value associated with key [a] in the list of
+ pairs [l]. That is,
+ [assoc_opt a [ ...; (a,b); ...] = b]
+ if [(a,b)] is the leftmost binding of [a] in list [l].
+ Returns [None] if there is no value associated with [a] in the
+ list [l].
+ @since 4.05 *)
+
val assq : 'a -> ('a * 'b) list -> 'b
(** Same as {!List.assoc}, but uses physical equality instead of structural
equality to compare keys. *)
+val assq_opt : 'a -> ('a * 'b) list -> 'b option
+(** Same as {!List.assoc_opt}, but uses physical equality instead of structural
+ equality to compare keys.
+ @since 4.05 *)
+
val mem_assoc : 'a -> ('a * 'b) list -> bool
(** Same as {!List.assoc}, but simply return true if a binding exists,
and false if no bindings exist for the given key. *)
(** Return the first element of the given list. Raise
[Failure "hd"] if the list is empty. *)
+val compare_lengths : 'a list -> 'b list -> int
+(** Compare the lengths of two lists. [compare_lengths l1 l2] is
+ equivalent to [compare (length l1) (length l2)], except that
+ the computation stops after itering on the shortest list.
+ @since 4.05.0
+ *)
+
+val compare_length_with : 'a list -> len:int -> int
+(** Compare the length of a list to an integer. [compare_length_with l n] is
+ equivalent to [compare (length l) n], except that
+ the computation stops after at most [n] iterations on the list.
+ @since 4.05.0
+*)
+
+val cons : 'a -> 'a list -> 'a list
+(** [cons x xs] is [x :: xs]
+ @since 4.05.0
+*)
+
val tl : 'a list -> 'a list
(** Return the given list without its first element. Raise
[Failure "tl"] if the list is empty. *)
Raise [Failure "nth"] if the list is too short.
Raise [Invalid_argument "List.nth"] if [n] is negative. *)
+val nth_opt: 'a list -> int -> 'a option
+(** Return the [n]-th element of the given list.
+ The first element (head of the list) is at position 0.
+ Return [None] if the list is too short.
+ Raise [Invalid_argument "List.nth"] if [n] is negative.
+ @since 4.05
+*)
+
val rev : 'a list -> 'a list
(** List reversal. *)
operator is not tail-recursive either. *)
val rev_append : 'a list -> 'a list -> 'a list
-(** [ListLabels.rev_append l1 l2] reverses [l1] and concatenates it to [l2].
- This is equivalent to {!ListLabels.rev}[ l1 @ l2], but [rev_append] is
+(** [List.rev_append l1 l2] reverses [l1] and concatenates it to [l2].
+ This is equivalent to {!List.rev}[ l1 @ l2], but [rev_append] is
tail-recursive and more efficient. *)
val concat : 'a list list -> 'a list
val iter : f:('a -> unit) -> 'a list -> unit
-(** [ListLabels.iter f [a1; ...; an]] applies function [f] in turn to
+(** [List.iter f [a1; ...; an]] applies function [f] in turn to
[a1; ...; an]. It is equivalent to
[begin f a1; f a2; ...; f an; () end]. *)
val iteri : f:(int -> 'a -> unit) -> 'a list -> unit
-(** Same as {!ListLabels.iter}, but the function is applied to the index of
+(** Same as {!List.iter}, but the function is applied to the index of
the element as first argument (counting from 0), and the element
itself as second argument.
@since 4.00.0
*)
val map : f:('a -> 'b) -> 'a list -> 'b list
-(** [ListLabels.map f [a1; ...; an]] applies function [f] to [a1, ..., an],
+(** [List.map f [a1; ...; an]] applies function [f] to [a1, ..., an],
and builds the list [[f a1; ...; f an]]
with the results returned by [f]. Not tail-recursive. *)
val mapi : f:(int -> 'a -> 'b) -> 'a list -> 'b list
-(** Same as {!ListLabels.map}, but the function is applied to the index of
+(** Same as {!List.map}, but the function is applied to the index of
the element as first argument (counting from 0), and the element
itself as second argument.
@since 4.00.0
*)
val rev_map : f:('a -> 'b) -> 'a list -> 'b list
-(** [ListLabels.rev_map f l] gives the same result as
- {!ListLabels.rev}[ (]{!ListLabels.map}[ f l)], but is tail-recursive and
+(** [List.rev_map f l] gives the same result as
+ {!List.rev}[ (]{!List.map}[ f l)], but is tail-recursive and
more efficient. *)
val fold_left : f:('a -> 'b -> 'a) -> init:'a -> 'b list -> 'a
-(** [ListLabels.fold_left f a [b1; ...; bn]] is
+(** [List.fold_left f a [b1; ...; bn]] is
[f (... (f (f a b1) b2) ...) bn]. *)
val fold_right : f:('a -> 'b -> 'b) -> 'a list -> init:'b -> 'b
-(** [ListLabels.fold_right f [a1; ...; an] b] is
+(** [List.fold_right f [a1; ...; an] b] is
[f a1 (f a2 (... (f an b) ...))]. Not tail-recursive. *)
val iter2 : f:('a -> 'b -> unit) -> 'a list -> 'b list -> unit
-(** [ListLabels.iter2 f [a1; ...; an] [b1; ...; bn]] calls in turn
+(** [List.iter2 f [a1; ...; an] [b1; ...; bn]] calls in turn
[f a1 b1; ...; f an bn].
Raise [Invalid_argument] if the two lists are determined
to have different lengths. *)
val map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
-(** [ListLabels.map2 f [a1; ...; an] [b1; ...; bn]] is
+(** [List.map2 f [a1; ...; an] [b1; ...; bn]] is
[[f a1 b1; ...; f an bn]].
Raise [Invalid_argument] if the two lists are determined
to have different lengths. Not tail-recursive. *)
val rev_map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
-(** [ListLabels.rev_map2 f l1 l2] gives the same result as
- {!ListLabels.rev}[ (]{!ListLabels.map2}[ f l1 l2)], but is tail-recursive and
+(** [List.rev_map2 f l1 l2] gives the same result as
+ {!List.rev}[ (]{!List.map2}[ f l1 l2)], but is tail-recursive and
more efficient. *)
val fold_left2 :
f:('a -> 'b -> 'c -> 'a) -> init:'a -> 'b list -> 'c list -> 'a
-(** [ListLabels.fold_left2 f a [b1; ...; bn] [c1; ...; cn]] is
+(** [List.fold_left2 f a [b1; ...; bn] [c1; ...; cn]] is
[f (... (f (f a b1 c1) b2 c2) ...) bn cn].
Raise [Invalid_argument] if the two lists are determined
to have different lengths. *)
val fold_right2 :
f:('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> init:'c -> 'c
-(** [ListLabels.fold_right2 f [a1; ...; an] [b1; ...; bn] c] is
+(** [List.fold_right2 f [a1; ...; an] [b1; ...; bn] c] is
[f a1 b1 (f a2 b2 (... (f an bn c) ...))].
Raise [Invalid_argument] if the two lists are determined
to have different lengths. Not tail-recursive. *)
[(p a1) || (p a2) || ... || (p an)]. *)
val for_all2 : f:('a -> 'b -> bool) -> 'a list -> 'b list -> bool
-(** Same as {!ListLabels.for_all}, but for a two-argument predicate.
+(** Same as {!List.for_all}, but for a two-argument predicate.
Raise [Invalid_argument] if the two lists are determined
to have different lengths. *)
val exists2 : f:('a -> 'b -> bool) -> 'a list -> 'b list -> bool
-(** Same as {!ListLabels.exists}, but for a two-argument predicate.
+(** Same as {!List.exists}, but for a two-argument predicate.
Raise [Invalid_argument] if the two lists are determined
to have different lengths. *)
to an element of [l]. *)
val memq : 'a -> set:'a list -> bool
-(** Same as {!ListLabels.mem}, but uses physical equality instead of structural
+(** Same as {!List.mem}, but uses physical equality instead of structural
equality to compare list elements. *)
Raise [Not_found] if there is no value that satisfies [p] in the
list [l]. *)
+val find_opt: f:('a -> bool) -> 'a list -> 'a option
+(** [find p l] returns the first element of the list [l]
+ that satisfies the predicate [p].
+ Returns [None] if there is no value that satisfies [p] in the
+ list [l].
+ @since 4.05 *)
+
val filter : f:('a -> bool) -> 'a list -> 'a list
(** [filter p l] returns all the elements of the list [l]
that satisfy the predicate [p]. The order of the elements
in the input list is preserved. *)
val find_all : f:('a -> bool) -> 'a list -> 'a list
-(** [find_all] is another name for {!ListLabels.filter}. *)
+(** [find_all] is another name for {!List.filter}. *)
val partition : f:('a -> bool) -> 'a list -> 'a list * 'a list
(** [partition p l] returns a pair of lists [(l1, l2)], where
Raise [Not_found] if there is no value associated with [a] in the
list [l]. *)
+val assoc_opt: 'a -> ('a * 'b) list -> 'b option
+(** [assoc_opt a l] returns the value associated with key [a] in the list of
+ pairs [l]. That is,
+ [assoc a [ ...; (a,b); ...] = b]
+ if [(a,b)] is the leftmost binding of [a] in list [l].
+ Returns [None] if there is no value associated with [a] in the
+ list [l].
+ @since 4.05
+*)
+
val assq : 'a -> ('a * 'b) list -> 'b
-(** Same as {!ListLabels.assoc}, but uses physical equality instead of
+(** Same as {!List.assoc}, but uses physical equality instead of
structural equality to compare keys. *)
+val assq_opt: 'a -> ('a * 'b) list -> 'b option
+(** Same as {!List.assoc_opt}, but uses physical equality instead of
+ structural equality to compare keys.
+ @since 4.05.0 *)
+
val mem_assoc : 'a -> map:('a * 'b) list -> bool
-(** Same as {!ListLabels.assoc}, but simply return true if a binding exists,
+(** Same as {!List.assoc}, but simply return true if a binding exists,
and false if no bindings exist for the given key. *)
val mem_assq : 'a -> map:('a * 'b) list -> bool
-(** Same as {!ListLabels.mem_assoc}, but uses physical equality instead of
+(** Same as {!List.mem_assoc}, but uses physical equality instead of
structural equality to compare keys. *)
val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list
Not tail-recursive. *)
val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list
-(** Same as {!ListLabels.remove_assoc}, but uses physical equality instead
+(** Same as {!List.remove_assoc}, but uses physical equality instead
of structural equality to compare keys. Not tail-recursive. *)
a complete specification). For example,
{!Pervasives.compare} is a suitable comparison function.
The resulting list is sorted in increasing order.
- [ListLabels.sort] is guaranteed to run in constant heap space
+ [List.sort] is guaranteed to run in constant heap space
(in addition to the size of the result list) and logarithmic
stack space.
*)
val stable_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list
-(** Same as {!ListLabels.sort}, but the sorting algorithm is guaranteed to
+(** Same as {!List.sort}, but the sorting algorithm is guaranteed to
be stable (i.e. elements that compare equal are kept in their
original order) .
*)
val fast_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list
-(** Same as {!ListLabels.sort} or {!ListLabels.stable_sort}, whichever is
+(** Same as {!List.sort} or {!List.stable_sort}, whichever is
faster on typical input. *)
val sort_uniq : cmp:('a -> 'a -> int) -> 'a list -> 'a list
-(** Same as {!ListLabels.sort}, but also remove duplicates.
- @since 4.02.0 *)
+(** Same as {!List.sort}, but also remove duplicates.
+ @since 4.03.0 *)
val merge : cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
(** Merge two lists:
val cardinal: 'a t -> int
val bindings: 'a t -> (key * 'a) list
val min_binding: 'a t -> (key * 'a)
+ val min_binding_opt: 'a t -> (key * 'a) option
val max_binding: 'a t -> (key * 'a)
+ val max_binding_opt: 'a t -> (key * 'a) option
val choose: 'a t -> (key * 'a)
+ val choose_opt: 'a t -> (key * 'a) option
val split: key -> 'a t -> 'a t * 'a option * 'a t
val find: key -> 'a t -> 'a
+ val find_opt: key -> 'a t -> 'a option
+ val find_first: (key -> bool) -> 'a t -> key * 'a
+ val find_first_opt: (key -> bool) -> 'a t -> (key * 'a) option
+ val find_last: (key -> bool) -> 'a t -> key * 'a
+ val find_last_opt: (key -> bool) -> 'a t -> (key * 'a) option
val map: ('a -> 'b) -> 'a t -> 'b t
val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t
end
if c = 0 then d
else find x (if c < 0 then l else r)
+ let rec find_first_aux v0 d0 f = function
+ Empty ->
+ (v0, d0)
+ | Node(l, v, d, r, _) ->
+ if f v then
+ find_first_aux v d f l
+ else
+ find_first_aux v0 d0 f r
+
+ let rec find_first f = function
+ Empty ->
+ raise Not_found
+ | Node(l, v, d, r, _) ->
+ if f v then
+ find_first_aux v d f l
+ else
+ find_first f r
+
+ let rec find_first_opt_aux v0 d0 f = function
+ Empty ->
+ Some (v0, d0)
+ | Node(l, v, d, r, _) ->
+ if f v then
+ find_first_opt_aux v d f l
+ else
+ find_first_opt_aux v0 d0 f r
+
+ let rec find_first_opt f = function
+ Empty ->
+ None
+ | Node(l, v, d, r, _) ->
+ if f v then
+ find_first_opt_aux v d f l
+ else
+ find_first_opt f r
+
+ let rec find_last_aux v0 d0 f = function
+ Empty ->
+ (v0, d0)
+ | Node(l, v, d, r, _) ->
+ if f v then
+ find_last_aux v d f r
+ else
+ find_last_aux v0 d0 f l
+
+ let rec find_last f = function
+ Empty ->
+ raise Not_found
+ | Node(l, v, d, r, _) ->
+ if f v then
+ find_last_aux v d f r
+ else
+ find_last f l
+
+ let rec find_last_opt_aux v0 d0 f = function
+ Empty ->
+ Some (v0, d0)
+ | Node(l, v, d, r, _) ->
+ if f v then
+ find_last_opt_aux v d f r
+ else
+ find_last_opt_aux v0 d0 f l
+
+ let rec find_last_opt f = function
+ Empty ->
+ None
+ | Node(l, v, d, r, _) ->
+ if f v then
+ find_last_opt_aux v d f r
+ else
+ find_last_opt f l
+
+ let rec find_opt x = function
+ Empty ->
+ None
+ | Node(l, v, d, r, _) ->
+ let c = Ord.compare x v in
+ if c = 0 then Some d
+ else find_opt x (if c < 0 then l else r)
+
let rec mem x = function
Empty ->
false
| Node(Empty, x, d, _, _) -> (x, d)
| Node(l, _, _, _, _) -> min_binding l
+ let rec min_binding_opt = function
+ Empty -> None
+ | Node(Empty, x, d, _, _) -> Some (x, d)
+ | Node(l, _, _, _, _) -> min_binding_opt l
+
let rec max_binding = function
Empty -> raise Not_found
| Node(_, x, d, Empty, _) -> (x, d)
| Node(_, _, _, r, _) -> max_binding r
+ let rec max_binding_opt = function
+ Empty -> None
+ | Node(_, x, d, Empty, _) -> Some (x, d)
+ | Node(_, _, _, r, _) -> max_binding_opt r
+
let rec remove_min_binding = function
Empty -> invalid_arg "Map.remove_min_elt"
| Node(Empty, _, _, r, _) -> r
let choose = min_binding
+ let choose_opt = min_binding_opt
+
end
(** [merge f m1 m2] computes a map whose keys is a subset of keys of [m1]
and of [m2]. The presence of each such binding, and the corresponding
value, is determined with the function [f].
+ In terms of the [find_opt] operation, we have
+ [find_opt x (merge f m1 m2) = f (find_opt x m1) (find_opt x m2)]
+ for any key [x], provided that [f None None = None].
@since 3.12.0
*)
(** [union f m1 m2] computes a map whose keys is the union of keys
of [m1] and of [m2]. When the same binding is defined in both
arguments, the function [f] is used to combine them.
+ This is a special case of [merge]: [union f m1 m2] is equivalent
+ to [merge f' m1 m2], where
+ - [f' None None = None]
+ - [f' (Some v) None = Some v]
+ - [f' None (Some v) = Some v]
+ - [f' (Some v1) (Some v2) = f v1 v2]
+
@since 4.03.0
*)
val exists: (key -> 'a -> bool) -> 'a t -> bool
(** [exists p m] checks if at least one binding of the map
- satisfy the predicate [p].
+ satisfies the predicate [p].
@since 3.12.0
*)
@since 3.12.0
*)
+ val min_binding_opt: 'a t -> (key * 'a) option
+ (** Return the smallest binding of the given map
+ (with respect to the [Ord.compare] ordering), or [None]
+ if the map is empty.
+ @since 4.05
+ *)
+
val max_binding: 'a t -> (key * 'a)
(** Same as {!Map.S.min_binding}, but returns the largest binding
of the given map.
@since 3.12.0
*)
+ val max_binding_opt: 'a t -> (key * 'a) option
+ (** Same as {!Map.S.min_binding_opt}, but returns the largest binding
+ of the given map.
+ @since 4.05
+ *)
+
val choose: 'a t -> (key * 'a)
(** Return one binding of the given map, or raise [Not_found] if
the map is empty. Which binding is chosen is unspecified,
@since 3.12.0
*)
+ val choose_opt: 'a t -> (key * 'a) option
+ (** Return one binding of the given map, or [None] if
+ the map is empty. Which binding is chosen is unspecified,
+ but equal bindings will be chosen for equal maps.
+ @since 4.05
+ *)
+
val split: key -> 'a t -> 'a t * 'a option * 'a t
(** [split x m] returns a triple [(l, data, r)], where
[l] is the map with all the bindings of [m] whose key
(** [find x m] returns the current binding of [x] in [m],
or raises [Not_found] if no such binding exists. *)
+ val find_opt: key -> 'a t -> 'a option
+ (** [find_opt x m] returns [Some v] if the current binding of [x]
+ in [m] is [v], or [None] if no such binding exists.
+ @since 4.05
+ *)
+
+ val find_first: (key -> bool) -> 'a t -> key * 'a
+ (** [find_first f m], where [f] is a monotonically increasing function,
+ returns the binding of [m] with the lowest key [k] such that [f k],
+ or raises [Not_found] if no such key exists.
+
+ For example, [find_first (fun k -> Ord.compare k x >= 0) m] will return
+ the first binding [k, v] of [m] where [Ord.compare k x >= 0]
+ (intuitively: [k >= x]), or raise [Not_found] if [x] is greater than any
+ element of [m].
+
+ @since 4.05
+ *)
+
+ val find_first_opt: (key -> bool) -> 'a t -> (key * 'a) option
+ (** [find_first_opt f m], where [f] is a monotonically increasing function,
+ returns an option containing the binding of [m] with the lowest key [k]
+ such that [f k], or [None] if no such key exists.
+ @since 4.05
+ *)
+
+ val find_last: (key -> bool) -> 'a t -> key * 'a
+ (** [find_last f m], where [f] is a monotonically decreasing function,
+ returns the binding of [m] with the highest key [k] such that [f k],
+ or raises [Not_found] if no such key exists.
+ @since 4.05
+ *)
+
+ val find_last_opt: (key -> bool) -> 'a t -> (key * 'a) option
+ (** [find_last_opt f m], where [f] is a monotonically decreasing function,
+ returns an option containing the binding of [m] with the highest key [k]
+ such that [f k], or [None] if no such key exists.
+ @since 4.05
+ *)
+
val map: ('a -> 'b) -> 'a t -> 'b t
(** [map f m] returns a map with same domain as [m], where the
associated value [a] of all bindings of [m] has been
digest of the code transmitted along with the code position.)
The exact definition of which free variables are captured in a
- closure is not specified and can very between bytecode and native
+ closure is not specified and can vary between bytecode and native
code (and according to optimization flags). In particular, a
function value accessing a global reference may or may not include
the reference in its closure. If it does, unmarshaling the
val copy : ('a, 'b) t -> ('a, 'b) t
val add : ('a, 'b) t -> key:'a -> data:'b -> unit
val find : ('a, 'b) t -> 'a -> 'b
+ val find_opt : ('a, 'b) t -> 'a -> 'b option
val find_all : ('a, 'b) t -> 'a -> 'b list
val mem : ('a, 'b) t -> 'a -> bool
val remove : ('a, 'b) t -> 'a -> unit
('a, 'b) t -> init:'c -> 'c
val length : ('a, 'b) t -> int
val randomize : unit -> unit
+ val is_randomized : unit -> bool
type statistics = Hashtbl.statistics
val stats : ('a, 'b) t -> statistics
module type HashedType = Hashtbl.HashedType
val add : 'a t -> key:key -> data:'a -> unit
val remove : 'a t -> key -> unit
val find : 'a t -> key -> 'a
+ val find_opt: 'a t -> key -> 'a option
val find_all : 'a t -> key -> 'a list
val replace : 'a t -> key:key -> data:'a -> unit
val mem : 'a t -> key -> bool
val add : 'a t -> key:key -> data:'a -> unit
val remove : 'a t -> key -> unit
val find : 'a t -> key -> 'a
+ val find_opt : 'a t -> key -> 'a option
val find_all : 'a t -> key -> 'a list
val replace : 'a t -> key:key -> data:'a -> unit
val mem : 'a t -> key -> bool
val cardinal: 'a t -> int
val bindings: 'a t -> (key * 'a) list
val min_binding: 'a t -> (key * 'a)
+ val min_binding_opt: 'a t -> (key * 'a) option
val max_binding: 'a t -> (key * 'a)
+ val max_binding_opt: 'a t -> (key * 'a) option
val choose: 'a t -> (key * 'a)
+ val choose_opt: 'a t -> (key * 'a) option
val split: key -> 'a t -> 'a t * 'a option * 'a t
val find : key -> 'a t -> 'a
+ val find_opt: key -> 'a t -> 'a option
+ val find_first : f:(key -> bool) -> 'a t -> key * 'a
+ val find_first_opt : f:(key -> bool) -> 'a t -> (key * 'a) option
+ val find_last : f:(key -> bool) -> 'a t -> key * 'a
+ val find_last_opt : f:(key -> bool) -> 'a t -> (key * 'a) option
val map : f:('a -> 'b) -> 'a t -> 'b t
val mapi : f:(key -> 'a -> 'b) -> 'a t -> 'b t
end
val cardinal : t -> int
val elements : t -> elt list
val min_elt : t -> elt
+ val min_elt_opt: t -> elt option
val max_elt : t -> elt
+ val max_elt_opt: t -> elt option
val choose : t -> elt
+ val choose_opt: t -> elt option
val split: elt -> t -> t * bool * t
val find: elt -> t -> elt
+ val find_opt: elt -> t -> elt option
+ val find_first: f:(elt -> bool) -> t -> elt
+ val find_first_opt: f:(elt -> bool) -> t -> elt option
+ val find_last: f:(elt -> bool) -> t -> elt
+ val find_last_opt: f:(elt -> bool) -> t -> elt option
val of_list: elt list -> t
end
module Make : functor (Ord : OrderedType) -> S with type elt = Ord.t
external of_string: string -> nativeint = "caml_nativeint_of_string"
+let of_string_opt s =
+ (* TODO: expose a non-raising primitive directly. *)
+ try Some (of_string s)
+ with Failure _ -> None
+
type t = nativeint
let compare (x: t) (y: t) = Pervasives.compare x y
or 2{^63} - 1 on a 64-bit platform. *)
val min_int : nativeint
-(** The greatest representable native integer,
+(** The smallest representable native integer,
either -2{^31} on a 32-bit platform,
or -2{^63} on a 64-bit platform. *)
a valid representation of an integer, or if the integer represented
exceeds the range of integers representable in type [nativeint]. *)
+val of_string_opt: string -> nativeint option
+(** Same as [of_string], but return [None] instead of raising.
+ @since 4.05 *)
+
val to_string : nativeint -> string
(** Return the string representation of its argument, in decimal. *)
{!Set.Make} and {!Map.Make}. *)
val equal: t -> t -> bool
-(** The equal function for natives ints.
+(** The equal function for native ints.
@since 4.03.0 *)
(**/**)
For experts only:
[set_field] et al can be made safe by first wrapping the block in
- [Sys.opaque_identity], so any information about its contents will not
+ {!Sys.opaque_identity}, so any information about its contents will not
be propagated.
*)
external set_field : t -> int -> t -> unit = "%obj_set_field"
external float_of_int : int -> float = "%floatofint"
external truncate : float -> int = "%intoffloat"
external int_of_float : float -> int = "%intoffloat"
-external float_of_bits : int64 -> float = "caml_int64_float_of_bits"
+external float_of_bits : int64 -> float
+ = "caml_int64_float_of_bits" "caml_int64_float_of_bits_unboxed"
+ [@@unboxed] [@@noalloc]
let infinity =
float_of_bits 0x7F_F0_00_00_00_00_00_00L
let neg_infinity =
| "false" -> false
| _ -> invalid_arg "bool_of_string"
+let bool_of_string_opt = function
+ | "true" -> Some true
+ | "false" -> Some false
+ | _ -> None
+
let string_of_int n =
format_int "%d" n
external int_of_string : string -> int = "caml_int_of_string"
+
+let int_of_string_opt s =
+ (* TODO: provide this directly as a non-raising primitive. *)
+ try Some (int_of_string s)
+ with Failure _ -> None
+
+
external string_get : string -> int -> char = "%string_safe_get"
let valid_float_lexem s =
external float_of_string : string -> float = "caml_float_of_string"
+let float_of_string_opt s =
+ (* TODO: provide this directly as a non-raising primitive. *)
+ try Some (float_of_string s)
+ with Failure _ -> None
+
(* List operations -- more in module List *)
let rec ( @ ) l1 l2 =
let read_line () = flush stdout; input_line stdin
let read_int () = int_of_string(read_line())
+let read_int_opt () = int_of_string_opt(read_line())
let read_float () = float_of_string(read_line())
+let read_float_opt () = float_of_string_opt(read_line())
(* Operations on large files *)
Raise [Invalid_argument "bool_of_string"] if the string is not
["true"] or ["false"]. *)
+val bool_of_string_opt: string -> bool option
+(** Convert the given string to a boolean.
+ Return [None] if the string is not
+ ["true"] or ["false"].
+ @since 4.05
+*)
+
val string_of_int : int -> string
(** Return the string representation of an integer, in decimal. *)
a valid representation of an integer, or if the integer represented
exceeds the range of integers representable in type [int]. *)
+
+val int_of_string_opt: string -> int option
+(** Same as [int_of_string], but returs [None] instead of raising.
+ @since 4.05
+*)
+
val string_of_float : float -> string
(** Return the string representation of a floating-point number. *)
Raise [Failure "float_of_string"] if the given string is not a valid
representation of a float. *)
+val float_of_string_opt: string -> float option
+(** Same as [float_of_string], but returns [None] instead of raising.
+ @since 4.05
+*)
+
(** {6 Pair operations} *)
external fst : 'a * 'b -> 'a = "%field0"
and convert it to an integer. Raise [Failure "int_of_string"]
if the line read is not a valid representation of an integer. *)
+val read_int_opt: unit -> int option
+(** Same as [read_int_opt], but returs [None] instead of raising.
+ @since 4.05
+*)
+
val read_float : unit -> float
(** Flush standard output, then read one line from standard input
and convert it to a floating-point number.
The result is unspecified if the line read is not a valid
representation of a floating-point number. *)
+val read_float_opt: unit -> float option
+(** Flush standard output, then read one line from standard input
+ and convert it to a floating-point number.
+ Returns [None] if the line read is not a valid
+ representation of a floating-point number.
+ @since 4.05.0 *)
+
(** {7 General output functions} *)
val open_out_gen : open_flag list -> int -> string -> out_channel
(** [open_out_gen mode perm filename] opens the named file for writing,
as described above. The extra argument [mode]
- specify the opening mode. The extra argument [perm] specifies
+ specifies the opening mode. The extra argument [perm] specifies
the file permissions, in case the file must be created.
{!Pervasives.open_out} and {!Pervasives.open_out_bin} are special
cases of this function. *)
(** {6 Result type} *)
+(** @since 4.03.0 *)
type ('a,'b) result = Ok of 'a | Error of 'b
(** {6 Operations on format strings} *)
- ['b] is the type of input source for formatted input functions and the
type of output target for formatted output functions.
- For [printf]-style functions from module [Printf], ['b] is typically
+ For [printf]-style functions from module {!Printf}, ['b] is typically
[out_channel];
- for [printf]-style functions from module [Format], ['b] is typically
- [Format.formatter];
- for [scanf]-style functions from module [Scanf], ['b] is typically
- [Scanf.Scanning.in_channel].
+ for [printf]-style functions from module {!Format}, ['b] is typically
+ {!Format.formatter};
+ for [scanf]-style functions from module {!Scanf}, ['b] is typically
+ {!Scanf.Scanning.in_channel}.
Type argument ['b] is also the type of the first argument given to
user's defined printing functions for [%a] and [%t] conversions,
external get_raw_backtrace:
unit -> raw_backtrace = "caml_get_exception_raw_backtrace"
+external raise_with_backtrace: exn -> raw_backtrace -> 'a
+ = "%raise_with_backtrace"
+
type backtrace_slot =
| Known_location of {
is_raise : bool;
(* confusingly named:
returns the *string* corresponding to the global current backtrace *)
-let get_backtrace () =
- backtrace_to_string (convert_raw_backtrace (get_raw_backtrace ()))
+let get_backtrace () = raw_backtrace_to_string (get_raw_backtrace ())
external record_backtrace: bool -> unit = "caml_record_backtrace"
external backtrace_status: unit -> bool = "caml_backtrace_status"
on the output channel [oc]. The backtrace lists the program
locations where the most-recently raised exception was raised
and where it was propagated through function calls.
+
+ If the call is not inside an exception handler, the returned
+ backtrace is unspecified. If the call is after some
+ exception-catching code (before in the handler, or in a when-guard
+ during the matching of the exception handler), the backtrace may
+ correspond to a later exception than the handled one.
+
@since 3.11.0
*)
val get_backtrace: unit -> string
(** [Printexc.get_backtrace ()] returns a string containing the
same exception backtrace that [Printexc.print_backtrace] would
- print.
+ print. Same restriction usage than {!print_backtrace}.
@since 3.11.0
*)
val get_raw_backtrace: unit -> raw_backtrace
(** [Printexc.get_raw_backtrace ()] returns the same exception
backtrace that [Printexc.print_backtrace] would print, but in
- a raw format.
+ a raw format. Same restriction usage than {!print_backtrace}.
@since 4.01.0
*)
@since 4.01.0
*)
+external raise_with_backtrace: exn -> raw_backtrace -> 'a
+ = "%raise_with_backtrace"
+(** Reraise the exception using the given raw_backtrace for the
+ origin of the exception
+
+ @since 4.05.0
+*)
+
(** {6 Current call stack} *)
val get_callstack: int -> raw_backtrace
@since 4.02
*)
+(** @since 4.02.0 *)
module Slot : sig
type t = backtrace_slot
*)
val get_raw_backtrace_slot : raw_backtrace -> int -> raw_backtrace_slot
-(** [get_slot bckt pos] returns the slot in position [pos] in the
+(** [get_raw_backtrace_slot bckt pos] returns the slot in position [pos] in the
backtrace [bckt].
@since 4.02
raw_backtrace_slot -> raw_backtrace_slot option
(** [get_raw_backtrace_next_slot slot] returns the next slot inlined, if any.
+ Sample code to iterate over all frames (inlined and non-inlined):
+ {[
+ (* Iterate over inlined frames *)
+ let rec iter_raw_backtrace_slot f slot =
+ f slot;
+ match get_raw_backtrace_next_slot slot with
+ | None -> ()
+ | Some slot' -> iter_raw_backtrace_slot f slot'
+
+ (* Iterate over stack frames *)
+ let iter_raw_backtrace f bt =
+ for i = 0 to raw_backtrace_length bt - 1 do
+ iter_raw_backtrace_slot f (get_raw_backtrace_slot bt i)
+ done
+ ]}
+
@since 4.04.0
*)
*)
val exn_slot_name: exn -> string
-(** [Printexc.exn_slot_id exn] returns the internal name of the constructor
+(** [Printexc.exn_slot_name exn] returns the internal name of the constructor
used to create the exception value [exn].
@since 4.02.0
val ikfprintf : ('b -> 'd) -> 'b -> ('a, 'b, 'c, 'd) format4 -> 'a
(** Same as [kfprintf] above, but does not print anything.
Useful to ignore some material when conditionally printing.
- @since 4.0
+ @since 4.01.0
*)
val ksprintf : (string -> 'd) -> ('a, unit, string, 'd) format4 -> 'a
val take : 'a t -> 'a
(** [take q] removes and returns the first element in queue [q],
- or raises [Empty] if the queue is empty. *)
+ or raises {!Empty} if the queue is empty. *)
val pop : 'a t -> 'a
(** [pop] is a synonym for [take]. *)
val peek : 'a t -> 'a
(** [peek q] returns the first element in queue [q], without removing
- it from the queue, or raises [Empty] if the queue is empty. *)
+ it from the queue, or raises {!Empty} if the queue is empty. *)
val top : 'a t -> 'a
(** [top] is a synonym for [peek]. *)
(** {6 Advanced functions} *)
-(** The functions from module [State] manipulate the current state
+(** The functions from module {!State} manipulate the current state
of the random generator explicitly.
This allows using one or several deterministic PRNGs,
even in a multi-threaded program, without interference from
(** {7 Functional input with format strings} *)
-(** The module [Scanf] provides formatted input functions or {e scanners}.
+(** The module {!Scanf} provides formatted input functions or {e scanners}.
The formatted input functions can read from any kind of input, including
strings, files, or anything that can return characters. The more general
module Scanning : sig
type in_channel
-(** The notion of input channel for the [Scanf] module:
+(** The notion of input channel for the {!Scanf} module:
those channels provide all the machinery necessary to read from any source
- of characters, including a [!Pervasives.in_channel] value.
- A [Scanf.Scanning.in_channel] value is also called a {i formatted input
+ of characters, including a {!Pervasives.in_channel} value.
+ A Scanf.Scanning.in_channel value is also called a {i formatted input
channel} or equivalently a {i scanning buffer}.
- The type [Scanning.scanbuf] below is an alias for [Scanning.in_channel].
+ The type {!Scanning.scanbuf} below is an alias for [Scanning.in_channel].
@since 3.12.0
*)
*)
val stdin : in_channel
-(** The standard input notion for the [Scanf] module.
- [Scanning.stdin] is the [Scanning.in_channel] formatted input channel
- attached to [!Pervasives.stdin].
+(** The standard input notion for the {!Scanf} module.
+ [Scanning.stdin] is the {!Scanning.in_channel} formatted input channel
+ attached to {!Pervasives.stdin}.
Note: in the interactive system, when input is read from
- [!Pervasives.stdin], the newline character that triggers evaluation is
+ {!Pervasives.stdin}, the newline character that triggers evaluation is
part of the input; thus, the scanning specifications must properly skip
this additional newline character (for instance, simply add a ['\n'] as
the last character of the format string).
*)
val open_in : file_name -> in_channel
-(** [Scanning.open_in fname] returns a [!Scanning.in_channel] formatted input
+(** [Scanning.open_in fname] returns a {!Scanning.in_channel} formatted input
channel for bufferized reading in text mode from file [fname].
Note:
*)
val open_in_bin : file_name -> in_channel
-(** [Scanning.open_in_bin fname] returns a [!Scanning.in_channel] formatted
+(** [Scanning.open_in_bin fname] returns a {!Scanning.in_channel} formatted
input channel for bufferized reading in binary mode from file [fname].
@since 3.12.0
*)
val close_in : in_channel -> unit
-(** Closes the [!Pervasives.in_channel] associated with the given
- [!Scanning.in_channel] formatted input channel.
+(** Closes the {!Pervasives.in_channel} associated with the given
+ {!Scanning.in_channel} formatted input channel.
@since 3.12.0
*)
val from_file : file_name -> in_channel
-(** An alias for [!Scanning.open_in] above. *)
+(** An alias for {!Scanning.open_in} above. *)
val from_file_bin : string -> in_channel
-(** An alias for [!Scanning.open_in_bin] above. *)
+(** An alias for {!Scanning.open_in_bin} above. *)
val from_string : string -> in_channel
-(** [Scanning.from_string s] returns a [!Scanning.in_channel] formatted
+(** [Scanning.from_string s] returns a {!Scanning.in_channel} formatted
input channel which reads from the given string.
Reading starts from the first character in the string.
The end-of-input condition is set when the end of the string is reached.
*)
val from_function : (unit -> char) -> in_channel
-(** [Scanning.from_function f] returns a [!Scanning.in_channel] formatted
+(** [Scanning.from_function f] returns a {!Scanning.in_channel} formatted
input channel with the given function as its reading method.
When scanning needs one more character, the given function is called.
*)
val from_channel : Pervasives.in_channel -> in_channel
-(** [Scanning.from_channel ic] returns a [!Scanning.in_channel] formatted
- input channel which reads from the regular [!Pervasives.in_channel] input
+(** [Scanning.from_channel ic] returns a {!Scanning.in_channel} formatted
+ input channel which reads from the regular {!Pervasives.in_channel} input
channel [ic] argument.
Reading starts at current reading position of [ic].
*)
val end_of_input : in_channel -> bool
(** [Scanning.end_of_input ic] tests the end-of-input condition of the given
- [!Scanning.in_channel] formatted input channel.
+ {!Scanning.in_channel} formatted input channel.
*)
val beginning_of_input : in_channel -> bool
(** [Scanning.beginning_of_input ic] tests the beginning of input condition
- of the given [!Scanning.in_channel] formatted input channel.
+ of the given {!Scanning.in_channel} formatted input channel.
*)
val name_of_input : in_channel -> string
(** [Scanning.name_of_input ic] returns the name of the character source
- for the given [!Scanning.in_channel] formatted input channel.
+ for the given {!Scanning.in_channel} formatted input channel.
@since 3.09.0
*)
val stdib : in_channel
[@@ocaml.deprecated "Use Scanf.Scanning.stdin instead."]
-(** A deprecated alias for [!Scanning.stdin], the scanning buffer reading from
- [!Pervasives.stdin].
+(** A deprecated alias for {!Scanning.stdin}, the scanning buffer reading from
+ {!Pervasives.stdin}.
*)
end
precisely, if [scan] is some formatted input function, then [scan
ic fmt f] applies [f] to all the arguments specified by format
string [fmt], when [scan] has read those arguments from the
- [!Scanning.in_channel] formatted input channel [ic].
+ {!Scanning.in_channel} formatted input channel [ic].
- For instance, the [!Scanf.scanf] function below has type
+ For instance, the {!Scanf.scanf} function below has type
[('a, 'b, 'c, 'd) scanner], since it is a formatted input function that
- reads from [!Scanning.stdin]: [scanf fmt f] applies [f] to the arguments
+ reads from {!Scanning.stdin}: [scanf fmt f] applies [f] to the arguments
specified by [fmt], reading those arguments from [!Pervasives.stdin] as
expected.
val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner
(** [bscanf ic fmt r1 ... rN f] reads characters from the
- [!Scanning.in_channel] formatted input channel [ic] and converts them to
+ {!Scanning.in_channel} formatted input channel [ic] and converts them to
values according to format string [fmt].
As a final step, receiver function [f] is applied to the values read and
gives the result of the [bscanf] call.
- the [scanf] facility is not intended for heavy duty lexical
analysis and parsing. If it appears not expressive enough for your
needs, several alternative exists: regular expressions (module
- [Str]), stream parsers, [ocamllex]-generated lexers,
+ {!Str}), stream parsers, [ocamllex]-generated lexers,
[ocamlyacc]-generated parsers.
*)
For instance, format ["%s@%%"] reads a string up to the next [%]
character, and format ["%s@%@"] reads a string up to the next [@].
- The scanning indications introduce slight differences in the syntax of
- [Scanf] format strings, compared to those used for the [Printf]
+ {!Scanf} format strings, compared to those used for the {!Printf}
module. However, the scanning indications are similar to those used in
- the [Format] module; hence, when producing formatted text to be scanned
- by [!Scanf.bscanf], it is wise to use printing functions from the
- [Format] module (or, if you need to use functions from [Printf], banish
+ the {!Format} module; hence, when producing formatted text to be scanned
+ by {!Scanf.bscanf}, it is wise to use printing functions from the
+ {!Format} module (or, if you need to use functions from {!Printf}, banish
or carefully double check the format strings that contain ['@']
characters).
*)
(** Scanners may raise the following exceptions when the input cannot be read
according to the format string:
- - Raise [Scanf.Scan_failure] if the input does not match the format.
+ - Raise {!Scanf.Scan_failure} if the input does not match the format.
- Raise [Failure] if a conversion to a number is not possible.
val scanf : ('a, 'b, 'c, 'd) scanner
(** Same as {!Scanf.bscanf}, but reads from the predefined formatted input
- channel {!Scanf.Scanning.stdin} that is connected to [!Pervasives.stdin].
+ channel {!Scanf.Scanning.stdin} that is connected to {!Pervasives.stdin}.
*)
val kscanf :
(** [bscanf_format ic fmt f] reads a format string token from the formatted
input channel [ic], according to the given format string [fmt], and
applies [f] to the resulting format string value.
- Raise [Scan_failure] if the format string value read does not have the
+ Raise {!Scan_failure} if the format string value read does not have the
same type as [fmt].
@since 3.09.0
*)
('a, 'b, 'c, 'd, 'e, 'f) format6 -> ('a, 'b, 'c, 'd, 'e, 'f) format6
(** [format_from_string s fmt] converts a string argument to a format string,
according to the given format string [fmt].
- Raise [Scan_failure] if [s], considered as a format string, does not
+ Raise {!Scan_failure} if [s], considered as a format string, does not
have the same type as [fmt].
@since 3.10.0
*)
Always return a copy of the argument, even if there is no escape sequence
in the argument.
- Raise [Scan_failure] if [s] is not properly escaped (i.e. [s] has invalid
+ Raise {!Scan_failure} if [s] is not properly escaped (i.e. [s] has invalid
escape sequences or special characters that are not properly escaped).
For instance, [String.unescaped "\""] will fail.
@since 4.00.0
[@@ocaml.deprecated "Use Scanning.from_channel then Scanf.bscanf."]
(** @deprecated [Scanf.fscanf] is error prone and deprecated since 4.03.0.
- This function violates the following invariant of the [Scanf] module:
- To preserve scanning semantics, all scanning functions defined in [Scanf]
- must read from a user defined [Scanning.in_channel] formatted input
+ This function violates the following invariant of the {!Scanf} module:
+ To preserve scanning semantics, all scanning functions defined in {!Scanf}
+ must read from a user defined {!Scanning.in_channel} formatted input
channel.
- If you need to read from a [!Pervasives.in_channel] input channel
- [ic], simply define a [!Scanning.in_channel] formatted input channel as in
+ If you need to read from a {!Pervasives.in_channel} input channel
+ [ic], simply define a {!Scanning.in_channel} formatted input channel as in
[let ib = Scanning.from_channel ic],
- then use [!Scanf.bscanf ib] as usual.
+ then use [Scanf.bscanf ib] as usual.
*)
val kfscanf :
val cardinal: t -> int
val elements: t -> elt list
val min_elt: t -> elt
+ val min_elt_opt: t -> elt option
val max_elt: t -> elt
+ val max_elt_opt: t -> elt option
val choose: t -> elt
+ val choose_opt: t -> elt option
val split: elt -> t -> t * bool * t
val find: elt -> t -> elt
+ val find_opt: elt -> t -> elt option
+ val find_first: (elt -> bool) -> t -> elt
+ val find_first_opt: (elt -> bool) -> t -> elt option
+ val find_last: (elt -> bool) -> t -> elt
+ val find_last_opt: (elt -> bool) -> t -> elt option
val of_list: elt list -> t
end
| Node(Empty, v, _, _) -> v
| Node(l, _, _, _) -> min_elt l
+ let rec min_elt_opt = function
+ Empty -> None
+ | Node(Empty, v, _, _) -> Some v
+ | Node(l, _, _, _) -> min_elt_opt l
+
let rec max_elt = function
Empty -> raise Not_found
| Node(_, v, Empty, _) -> v
| Node(_, _, r, _) -> max_elt r
+ let rec max_elt_opt = function
+ Empty -> None
+ | Node(_, v, Empty, _) -> Some v
+ | Node(_, _, r, _) -> max_elt_opt r
+
(* Remove the smallest element of the given set *)
let rec remove_min_elt = function
let choose = min_elt
+ let choose_opt = min_elt_opt
+
let rec find x = function
Empty -> raise Not_found
| Node(l, v, r, _) ->
if c = 0 then v
else find x (if c < 0 then l else r)
+ let rec find_first_aux v0 f = function
+ Empty ->
+ v0
+ | Node(l, v, r, _) ->
+ if f v then
+ find_first_aux v f l
+ else
+ find_first_aux v0 f r
+
+ let rec find_first f = function
+ Empty ->
+ raise Not_found
+ | Node(l, v, r, _) ->
+ if f v then
+ find_first_aux v f l
+ else
+ find_first f r
+
+ let rec find_first_opt_aux v0 f = function
+ Empty ->
+ Some v0
+ | Node(l, v, r, _) ->
+ if f v then
+ find_first_opt_aux v f l
+ else
+ find_first_opt_aux v0 f r
+
+ let rec find_first_opt f = function
+ Empty ->
+ None
+ | Node(l, v, r, _) ->
+ if f v then
+ find_first_opt_aux v f l
+ else
+ find_first_opt f r
+
+ let rec find_last_aux v0 f = function
+ Empty ->
+ v0
+ | Node(l, v, r, _) ->
+ if f v then
+ find_last_aux v f r
+ else
+ find_last_aux v0 f l
+
+ let rec find_last f = function
+ Empty ->
+ raise Not_found
+ | Node(l, v, r, _) ->
+ if f v then
+ find_last_aux v f r
+ else
+ find_last f l
+
+ let rec find_last_opt_aux v0 f = function
+ Empty ->
+ Some v0
+ | Node(l, v, r, _) ->
+ if f v then
+ find_last_opt_aux v f r
+ else
+ find_last_opt_aux v0 f l
+
+ let rec find_last_opt f = function
+ Empty ->
+ None
+ | Node(l, v, r, _) ->
+ if f v then
+ find_last_opt_aux v f r
+ else
+ find_last_opt f l
+
+ let rec find_opt x = function
+ Empty -> None
+ | Node(l, v, r, _) ->
+ let c = Ord.compare x v in
+ if c = 0 then Some v
+ else find_opt x (if c < 0 then l else r)
+
+ let try_join l v r =
+ (* [join l v r] can only be called when (elements of l < v <
+ elements of r); use [try_join l v r] when this property may
+ not hold, but you hope it does hold in the common case *)
+ 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)
+
let rec map f = function
| Empty -> Empty
| Node (l, v, r, _) as t ->
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
+ else try_join l' v' r'
let of_sorted_list l =
let rec sub n l =
reasonably efficient: insertion and membership take time
logarithmic in the size of the set, for instance.
- The [Make] functor constructs implementations for any type, given a
+ The {!Make} functor constructs implementations for any type, given a
[compare] function.
For instance:
{[
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].) *)
+ input, the returned set is physically equal to [s].)
+ @since 4.04.0 *)
val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a
(** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)],
(with respect to the [Ord.compare] ordering), or raise
[Not_found] if the set is empty. *)
+ val min_elt_opt: t -> elt option
+ (** Return the smallest element of the given set
+ (with respect to the [Ord.compare] ordering), or [None]
+ if the set is empty.
+ @since 4.05
+ *)
+
val max_elt: t -> elt
(** Same as {!Set.S.min_elt}, but returns the largest element of the
given set. *)
+ val max_elt_opt: t -> elt option
+ (** Same as {!Set.S.min_elt_opt}, but returns the largest element of the
+ given set.
+ @since 4.05
+ *)
+
val choose: t -> elt
(** Return one element of the given set, or raise [Not_found] if
the set is empty. Which element is chosen is unspecified,
but equal elements will be chosen for equal sets. *)
+ val choose_opt: t -> elt option
+ (** Return one element of the given set, or [None] if
+ the set is empty. Which element is chosen is unspecified,
+ but equal elements will be chosen for equal sets.
+ @since 4.05
+ *)
+
val split: elt -> t -> t * bool * t
(** [split x s] returns a triple [(l, present, r)], where
[l] is the set of elements of [s] that are
exists.
@since 4.01.0 *)
+ val find_opt: elt -> t -> elt option
+ (** [find_opt x s] returns the element of [s] equal to [x] (according
+ to [Ord.compare]), or [None] if no such element
+ exists.
+ @since 4.05 *)
+
+ val find_first: (elt -> bool) -> t -> elt
+ (** [find_first f s], where [f] is a monotonically increasing function,
+ returns the lowest element [e] of [s] such that [f e],
+ or raises [Not_found] if no such element exists.
+
+ For example, [find_first (fun e -> Ord.compare e x >= 0) s] will return
+ the first element [e] of [s] where [Ord.compare e x >= 0] (intuitively:
+ [e >= x]), or raise [Not_found] if [x] is greater than any element of
+ [s].
+
+ @since 4.05
+ *)
+
+ val find_first_opt: (elt -> bool) -> t -> elt option
+ (** [find_first_opt f s], where [f] is a monotonically increasing function,
+ returns an option containing the lowest element [e] of [s] such that
+ [f e], or [None] if no such element exists.
+ @since 4.05
+ *)
+
+ val find_last: (elt -> bool) -> t -> elt
+ (** [find_last f s], where [f] is a monotonically decreasing function,
+ returns the highest element [e] of [s] such that [f e],
+ or raises [Not_found] if no such element exists.
+ @since 4.05
+ *)
+
+ val find_last_opt: (elt -> bool) -> t -> elt option
+ (** [find_last_opt f s], where [f] is a monotonically decreasing function,
+ returns an option containing the highest element [e] of [s] such that
+ [f e], or [None] if no such element exists.
+ @since 4.05
+ *)
+
val of_list: elt list -> t
(** [of_list l] creates a set from a list of elements.
This is usually more efficient than folding [add] over the list,
external spacetime_enabled : unit -> bool
= "caml_spacetime_enabled" [@@noalloc]
+let enabled = spacetime_enabled ()
+
let if_spacetime_enabled f =
- if spacetime_enabled () then f () else ()
+ if enabled then f () else ()
module Series = struct
type t = {
For functions to decode the information recorded by the profiler,
see the Spacetime offline library in otherlibs/. *)
+(** [enabled] is [true] if the compiler is configured with spacetime and [false]
+ otherwise *)
+val enabled : bool
+
module Series : sig
(** Type representing a file that will hold a series of heap snapshots
together with additional information required to interpret those
(** [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].
+ The optional [time] parameter is as for {!Snapshot.take}.
*)
val save_event : ?time:float -> t -> event_name:string -> unit
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].
+ The optional [time] parameter is as for {!Snapshot.take}.
*)
val save_and_close : ?time:float -> t -> unit
end
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
+ 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
val take : ?time:float -> Series.t -> unit
end
-(** Like [Series.save_event], but writes to the automatic snapshot file.
+(** 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
val pop : 'a t -> 'a
(** [pop s] removes and returns the topmost element in stack [s],
- or raises [Empty] if the stack is empty. *)
+ or raises {!Empty} if the stack is empty. *)
val top : 'a t -> 'a
(** [top s] returns the topmost element in stack [s],
- or raises [Empty] if the stack is empty. *)
+ or raises {!Empty} if the stack is empty. *)
val clear : 'a t -> unit
(** Discard all elements from a stack. *)
val next : 'a t -> 'a
(** Return the first element of the stream and remove it from the
- stream. Raise Stream.Failure if the stream is empty. *)
+ stream. Raise {!Stream.Failure} if the stream is empty. *)
val empty : 'a t -> unit
-(** Return [()] if the stream is empty, else raise [Stream.Failure]. *)
+(** Return [()] if the stream is empty, else raise {!Stream.Failure}. *)
(** {6 Useful functions} *)
let concat sep = function
[] -> ""
| l -> let seplen = length sep in bts @@
- unsafe_blits
+ unsafe_blits
(B.create (sum_lengths 0 seplen l))
0 sep seplen l
(* duplicated in bytes.ml *)
let index s c = index_rec s (length s) 0 c
+(* duplicated in bytes.ml *)
+let rec index_rec_opt s lim i c =
+ if i >= lim then None else
+ if unsafe_get s i = c then Some i else index_rec_opt s lim (i + 1) c
+
+(* duplicated in bytes.ml *)
+let index_opt s c = index_rec_opt 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 index_from_opt s i c =
+ let l = length s in
+ if i < 0 || i > l then invalid_arg "String.index_from_opt / Bytes.index_from_opt" else
+ index_rec_opt s l i c
+
(* duplicated in bytes.ml *)
let rec rindex_rec s i c =
if i < 0 then raise Not_found else
else
rindex_rec s i c
+(* duplicated in bytes.ml *)
+let rec rindex_rec_opt s i c =
+ if i < 0 then None else
+ if unsafe_get s i = c then Some i else rindex_rec_opt s (i - 1) c
+
+(* duplicated in bytes.ml *)
+let rindex_opt s c = rindex_rec_opt s (length s - 1) c
+
+(* duplicated in bytes.ml *)
+let rindex_from_opt s i c =
+ if i < -1 || i >= length s then
+ invalid_arg "String.rindex_from_opt / Bytes.rindex_from_opt"
+ else
+ rindex_rec_opt s i c
+
(* duplicated in bytes.ml *)
let contains_from s i c =
let l = length s in
Raise [Not_found] if [c] does not occur in [s]. *)
+val index_opt: string -> char -> int option
+(** [String.index_opt s c] returns the index of the first
+ occurrence of character [c] in string [s], or
+ [None] if [c] does not occur in [s].
+ @since 4.05 *)
+
val rindex : string -> char -> int
(** [String.rindex s c] returns the index of the last
occurrence of character [c] in string [s].
Raise [Not_found] if [c] does not occur in [s]. *)
+val rindex_opt: string -> char -> int option
+(** [String.rindex_opt s c] returns the index of the last occurrence
+ of character [c] in string [s], or [None] if [c] does not occur in
+ [s].
+ @since 4.05 *)
+
val index_from : string -> int -> char -> int
(** [String.index_from s i c] returns the index of the
first occurrence of character [c] in string [s] after position [i].
Raise [Invalid_argument] if [i] is not a valid position in [s].
Raise [Not_found] if [c] does not occur in [s] after position [i]. *)
+val index_from_opt: string -> int -> char -> int option
+(** [String.index_from_opt s i c] returns the index of the
+ first occurrence of character [c] in string [s] after position [i]
+ or [None] if [c] does not occur in [s] after position [i].
+
+ [String.index_opt s c] is equivalent to [String.index_from_opt s 0 c].
+ Raise [Invalid_argument] if [i] is not a valid position in [s].
+
+ @since 4.05
+*)
+
val rindex_from : string -> int -> char -> int
(** [String.rindex_from s i c] returns the index of the
last occurrence of character [c] in string [s] before position [i+1].
Raise [Invalid_argument] if [i+1] is not a valid position in [s].
Raise [Not_found] if [c] does not occur in [s] before position [i+1]. *)
+val rindex_from_opt: string -> int -> char -> int option
+(** [String.rindex_from_opt s i c] returns the index of the
+ last occurrence of character [c] in string [s] before position [i+1]
+ or [None] if [c] does not occur in [s] before position [i+1].
+
+ [String.rindex_opt s c] is equivalent to
+ [String.rindex_from_opt s (String.length s - 1) c].
+
+ Raise [Invalid_argument] if [i+1] is not a valid position in [s].
+
+ @since 4.05
+*)
+
val contains : string -> char -> bool
(** [String.contains s c] tests if character [c]
appears in the string [s]. *)
(** [init n f] returns a string of length [n],
with character [i] initialized to the result of [f i].
- Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *)
+ Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}.
+ @since 4.02.0 *)
val copy : string -> string
(** Return a copy of the given string. *)
Raise [Not_found] if [c] does not occur in [s]. *)
+val index_opt: string -> char -> int option
+(** [String.index_opt s c] returns the index of the first
+ occurrence of character [c] in string [s], or
+ [None] if [c] does not occur in [s].
+ @since 4.05 *)
+
val rindex : string -> char -> int
(** [String.rindex s c] returns the index of the last
occurrence of character [c] in string [s].
Raise [Not_found] if [c] does not occur in [s]. *)
+val rindex_opt: string -> char -> int option
+(** [String.rindex_opt s c] returns the index of the last occurrence
+ of character [c] in string [s], or [None] if [c] does not occur in
+ [s].
+ @since 4.05 *)
+
val index_from : string -> int -> char -> int
(** [String.index_from s i c] returns the index of the
first occurrence of character [c] in string [s] after position [i].
Raise [Invalid_argument] if [i] is not a valid position in [s].
Raise [Not_found] if [c] does not occur in [s] after position [i]. *)
+val index_from_opt: string -> int -> char -> int option
+(** [String.index_from_opt s i c] returns the index of the
+ first occurrence of character [c] in string [s] after position [i]
+ or [None] if [c] does not occur in [s] after position [i].
+
+ [String.index_opt s c] is equivalent to [String.index_from_opt s 0 c].
+ Raise [Invalid_argument] if [i] is not a valid position in [s].
+
+ @since 4.05
+*)
+
val rindex_from : string -> int -> char -> int
(** [String.rindex_from s i c] returns the index of the
last occurrence of character [c] in string [s] before position [i+1].
Raise [Invalid_argument] if [i+1] is not a valid position in [s].
Raise [Not_found] if [c] does not occur in [s] before position [i+1]. *)
+val rindex_from_opt: string -> int -> char -> int option
+(** [String.rindex_from_opt s i c] returns the index of the
+ last occurrence of character [c] in string [s] before position [i+1]
+ or [None] if [c] does not occur in [s] before position [i+1].
+
+ [String.rindex_opt s c] is equivalent to
+ [String.rindex_from_opt s (String.length s - 1) c].
+
+ Raise [Invalid_argument] if [i+1] is not a valid position in [s].
+
+ @since 4.05
+*)
+
val contains : string -> char -> bool
(** [String.contains s c] tests if character [c]
appears in the string [s]. *)
position in [s]. *)
val uppercase : string -> string
+ [@@ocaml.deprecated "Use String.uppercase_ascii instead."]
(** Return a copy of the argument, with all lowercase letters
translated to uppercase, including accented letters of the ISO
- Latin-1 (8859-1) character set. *)
+ Latin-1 (8859-1) character set.
+ @deprecated Functions operating on Latin-1 character set are deprecated. *)
val lowercase : string -> string
+ [@@ocaml.deprecated "Use String.lowercase_ascii instead."]
(** Return a copy of the argument, with all uppercase letters
translated to lowercase, including accented letters of the ISO
- Latin-1 (8859-1) character set. *)
+ Latin-1 (8859-1) character set.
+ @deprecated Functions operating on Latin-1 character set are deprecated. *)
val capitalize : string -> string
-(** Return a copy of the argument, with the first character set to uppercase. *)
+ [@@ocaml.deprecated "Use String.capitalize_ascii instead."]
+(** Return a copy of the argument, with the first character set to uppercase,
+ using the ISO Latin-1 (8859-1) character set..
+ @deprecated Functions operating on Latin-1 character set are deprecated. *)
val uncapitalize : string -> string
-(** Return a copy of the argument, with the first character set to lowercase. *)
+ [@@ocaml.deprecated "Use String.uncapitalize_ascii instead."]
+(** Return a copy of the argument, with the first character set to lowercase,
+ using the ISO Latin-1 (8859-1) character set..
+ @deprecated Functions operating on Latin-1 character set are deprecated. *)
+
+val uppercase_ascii : string -> string
+(** Return a copy of the argument, with all lowercase letters
+ translated to uppercase, using the US-ASCII character set.
+ @since 4.05.0 *)
+
+val lowercase_ascii : string -> string
+(** Return a copy of the argument, with all uppercase letters
+ translated to lowercase, using the US-ASCII character set.
+ @since 4.05.0 *)
+
+val capitalize_ascii : string -> string
+(** Return a copy of the argument, with the first character set to uppercase,
+ using the US-ASCII character set.
+ @since 4.05.0 *)
+
+val uncapitalize_ascii : string -> string
+(** Return a copy of the argument, with the first character set to lowercase,
+ using the US-ASCII character set.
+ @since 4.05.0 *)
type t = string
(** An alias for the type of strings. *)
allows the module [String] to be passed as argument to the functors
{!Set.Make} and {!Map.Make}. *)
+val equal: t -> t -> bool
+(** The equal function for strings.
+ @since 4.05.0 *)
+
+val split_on_char: sep: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.05.0
+*)
+
(**/**)
(* The following is for system use only. Do not call directly. *)
(** Return the value associated to a variable in the process
environment. Raise [Not_found] if the variable is unbound. *)
+val getenv_opt: string -> string option
+(** Return the value associated to a variable in the process
+ environment or [None] if the variable is unbound.
+ @since 4.05
+*)
+
external command : string -> int = "caml_sys_system_command"
(** Execute the given shell command and return its exit code. *)
val backend_type : backend_type
(** Backend type currently executing the OCaml program.
- @ since 4.04.0
+ @since 4.04.0
*)
val unix : bool
external remove: string -> unit = "caml_sys_remove"
external rename : string -> string -> unit = "caml_sys_rename"
external getenv: string -> string = "caml_sys_getenv"
+
+let getenv_opt s =
+ (* TODO: expose a non-raising primitive directly. *)
+ try Some (getenv s)
+ with Not_found -> None
+
external command: string -> int = "caml_sys_system_command"
external time: unit -> (float [@unboxed]) =
"caml_sys_time" "caml_sys_time_unboxed" [@@noalloc]
(* *)
(**************************************************************************)
+external format_int : string -> int -> string = "caml_format_int"
+
let err_no_pred = "U+0000 has no predecessor"
let err_no_succ = "U+10FFFF has no successor"
-let err_not_sv i = Printf.sprintf "%X is not an Unicode scalar value" i
-let err_not_latin1 u = Printf.sprintf "U+%04X is not a latin1 character" u
+let err_not_sv i = format_int "%X" i ^ " is not an Unicode scalar value"
+let err_not_latin1 u = "U+" ^ format_int "%04X" u ^ " is not a latin1 character"
type t = int
let equal : int -> int -> bool = ( = )
let compare : int -> int -> int = Pervasives.compare
let hash = to_int
-
-let dump ppf u = Format.fprintf ppf "U+%04X" u
val hash : t -> int
(** [hash u] associates a non-negative integer to [u]. *)
-
-val dump : Format.formatter -> t -> unit
-(** [dump ppf u] prints a representation of [u] on [ppf] using
- only US-ASCII encoded characters according to the Unicode
- {{:http://www.unicode.org/versions/latest/appA.pdf}notational
- convention for code points}. *)
val add : t -> data -> unit
val remove : t -> data -> unit
val find : t -> data -> data
+ val find_opt : t -> data -> data option
val find_all : t -> data -> data list
val mem : t -> data -> bool
val iter : (data -> unit) -> t -> unit
let find t d = find_or t d (fun _h _index -> raise Not_found)
+ let find_opt t d =
+ let h = H.hash d in
+ let index = get_index t h in
+ let bucket = t.table.(index) in
+ let hashes = t.hashes.(index) in
+ let sz = length bucket in
+ let rec loop i =
+ if i >= sz then None
+ else if h = hashes.(i) then begin
+ match get_copy bucket i with
+ | Some v when H.equal v d
+ -> begin match get bucket i with
+ | Some _ as v -> v
+ | None -> loop (i + 1)
+ end
+ | _ -> loop (i + 1)
+ end else loop (i + 1)
+ in
+ loop 0
+
let find_shadow t d iffound ifnotfound =
let h = H.hash d in
the incremental GC from erasing the value in its current cycle
([get] may delay the erasure to the next GC cycle).
Raise [Invalid_argument "Weak.get"] if [n] is not in the range
- 0 to {!Weak.length}[ a - 1].*)
+ 0 to {!Weak.length}[ a - 1].
+
+ If the element is a custom block it is not copied.
+
+*)
val check : 'a t -> int -> bool
(** [find t x] returns an instance of [x] found in [t].
Raise [Not_found] if there is no such element. *)
+ val find_opt: t -> data -> data option
+ (** [find_opt t x] returns an instance of [x] found in [t]
+ or [None] if there is no such element.
+ @since 4.05
+ *)
+
val find_all : t -> data -> data list
(** [find_all t x] returns a list of all the instances of [x]
found in [t]. *)
--- /dev/null
+== Running the testsuite
+
+== Creating a new test
+
+== Useful Makefile targets
+
+`make parallel`:: runs the tests in parallel using the link:https://www.gnu.org/software/parallel/[GNU parallel] tool: tests run twice as fast with no difference in output order.
+
+`make all-foo`, `make parallel-foo`:: runs only the tests in the directories whose name starts with `foo`: `parallel-typing`, `all-lib`, etc.
+
+`make one DIR=tests/foo`:: runs only the tests in the directory `tests/foo`. This is often equivalent to `cd tests/foo && make`, but sometimes the latter breaks the test makefile if it contains fragile relative filesystem paths. Such errors should be fixed if you find them, but `make one DIR=...` is the more reliable option as it runs exactly as `make all` which is heavily tested.
\ No newline at end of file
.mll.ml:
@$(OCAMLLEX) -q $< > /dev/null
-.cmm.o:
- @$(OCAMLRUN) ./codegen $*.cmm > $*.s
- @$(ASM) -o $*.o $*.s
+.cmm.s:
+ @$(OCAMLRUN) ./codegen -S $*.cmm
.cmm.obj:
@$(OCAMLRUN) ./codegen $*.cmm \
.S.o:
@$(ASPP) $(ASPPFLAGS) -DSYS_$(SYSTEM) -DMODEL_$(MODEL) -o $*.o $*.S
+.PRECIOUS: %.s
.s.o:
@$(ASPP) $(ASPPFLAGS) -DSYS_$(SYSTEM) -o $*.o $*.s
CUSTOM_FLAG=`if [ -n "$(C_FILES)" ]; then echo '-custom'; fi`
ADD_CFLAGS+=$(CUSTOM_FLAG)
-MYRUNTIME=`if [ -z "$(C_FILES)$(CUSTOM)" ]; then echo '$(OCAMLRUN)'; fi`
+MYRUNTIME=`if [ -z "$(C_FILES)$(CUSTOM)" ]; then echo '$(OCAMLRUN)'; echo '$(ADD_BYTERUN_FLAGS)'; fi`
FORTRAN_LIB=`if [ -n "$(F_FILES)" ]; then echo $(FORTRAN_LIBRARY); fi`
ADD_CFLAGS+=$(FORTRAN_LIB)
ADD_OPTFLAGS+=$(FORTRAN_LIB)
-C_INCLUDES+=-I $(CTOPDIR)/byterun -I$(CTOPDIR)/otherlibs/bigarray
+C_INCLUDES+=-I $(CTOPDIR)/byterun -I $(CTOPDIR)/otherlibs/bigarray
GENERATED_SOURCES=
if [ -f $$F.runner ]; then \
RUNTIME="$(RUNTIME)" sh $$F.runner; \
else \
- $(RUNTIME) ./program$(EXE) $(PROGRAM_ARGS) >$$F.result; \
+ $(SET_LD_PATH) $(RUNTIME) ./program$(EXE) $(PROGRAM_ARGS) >$$F.result; \
fi \
&& \
if [ -f $$F.checker ]; then \
BASEDIR=../..
INCLUDES=\
+ -I $(OTOPDIR)/parsing \
-I $(OTOPDIR)/utils \
-I $(OTOPDIR)/typing \
-I $(OTOPDIR)/middle_end \
@$(MAKE) arch codegen
@$(MAKE) tests
+main.cmo: parsecmm.cmo
+
codegen: parsecmm.ml lexcmm.ml $(OBJS:.cmo=.cmi) $(OBJS) main.cmo
@$(OCAMLC) $(LINKFLAGS) -o codegen $(OTHEROBJS) $(OBJS) main.cmo
MLCASES=optargs staticalloc bind_tuples is_static register_typing \
register_typing_switch
+ARGS_optargs=-g
ARGS_is_static=-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
-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
+ arith checkbound tagged-fib tagged-integr tagged-quicksort tagged-tak \
+ catch-try catch-rec even-odd even-odd-spill pgcd
ARGS_fib=-DINT_INT -DFUN=fib main.c
ARGS_tak=-DUNIT_INT -DFUN=takmain main.c
ARGS_quicksort=-DSORT -DFUN=quicksort 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
+ARGS_catch-try=-DINT_INT -DFUN=catch_exit main.c
+ARGS_catch-rec=-DINT_INT -DFUN=catch_fact main.c
+ARGS_even-odd=-DINT_INT -DFUN=is_even main.c
+ARGS_even-odd-spill=-DINT_INT -DFUN=is_even main.c
+ARGS_pgcd=-DINT_INT -DFUN=pgcd_30030 main.c
skips:
@for c in $(CASES) $(MLCASES) $(MLCASES_FLAMBDA); do \
--- /dev/null
+(function "catch_fact" (b:int)
+ (catch (exit fact b 1)
+ with (fact c acc)
+ (if (== c 0) acc
+ (exit fact (- c 1) ( * c acc)))))
--- /dev/null
+
+(function "catch_exit" (b:int)
+ (+ 33
+ (catch
+ (try (exit lbl 12)
+ with var 456)
+ with (lbl x) (+ x 789))))
--- /dev/null
+("format_odd": string "odd %d\n\000")
+("format_even": string "even %d\n\000")
+
+(function "force_spill" (a:int) 0)
+
+(function "is_even" (b:int)
+ (catch (exit even b)
+ with (odd v)
+ (if (== v 0) 0
+ (seq
+ (extcall "printf_int" "format_odd" v unit)
+ (let v2 (- v 1)
+ (app "force_spill" 0 int)
+ (exit even v2))))
+ and (even v)
+ (if (== v 0) 1
+ (seq
+ (extcall "printf_int" "format_even" v unit)
+ (exit odd (- v 1))))))
--- /dev/null
+(function "is_even" (b:int)
+ (catch (exit even b)
+ with (odd v)
+ (if (== v 0) 0
+ (exit even (- v 1)))
+ and (even v)
+ (if (== v 0) 1
+ (exit odd (- v 1)))))
\ No newline at end of file
"case", CASE;
"catch", CATCH;
"checkbound", CHECKBOUND;
+ "data", DATA;
"exit", EXIT;
"extcall", EXTCALL;
"float", FLOAT;
"float64", FLOAT64;
"floatofint", FLOATOFINT;
"function", FUNCTION;
+ "global", GLOBAL;
"half", HALF;
"if", IF;
"int", INT;
}
+let newline = ('\013'* '\010')
+
rule token = parse
- [' ' '\010' '\013' '\009' '\012'] +
+ newline
+ { Lexing.new_line lexbuf; token lexbuf }
+ | [' ' '\009' '\012'] +
{ token lexbuf }
| "+a" { ADDA }
| "+v" { ADDV }
| "<f" { LTF }
| "<" { LTI }
| "*f" { MULF }
- | "*" { MULI }
+ | "*" { STAR }
| "!=a" { NEA }
| "!=f" { NEF }
| "!=" { NEI }
| "]" { RBRACKET }
| ")" { RPAREN }
- | "*" { STAR }
| "-f" { SUBF }
| "-" { SUBI }
| '-'? (['0'-'9']+ | "0x" ['0'-'9' 'a'-'f' 'A'-'F']+
{ FLOATCONST(Lexing.lexeme lexbuf) }
| ['A'-'Z' 'a'-'z' '\223'-'\246' '\248'-'\255' ]
(['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255'
- '\'' '0'-'9' ]) *
+ '\'' '0'-'9' ]) * '/'? (['0'-'9'] *)
{ let s = Lexing.lexeme lexbuf in
try
Hashtbl.find keyword_table s
{ comment_depth := 1;
comment lexbuf;
token lexbuf }
+ | '{' ['A' - 'Z' 'a'-'z' '/' ',' '.' '-' '_' ' ''0'-'9']+
+ ':' [ '0'-'9' ]+ ',' ['0'-'9' ]+ '-' ['0'-'9' ]+ '}'
+ {
+ let loc_s = Lexing.lexeme lexbuf in
+ let pos_fname, pos_lnum, start, end_ =
+ Scanf.sscanf loc_s "{%s@:%i,%i-%i}" (fun file line start end_ ->
+ (file, line, start, end_))
+ in
+ let loc_start =
+ Lexing.{ pos_fname; pos_lnum; pos_bol = 0; pos_cnum = start }
+ in
+ let loc_end =
+ Lexing.{ pos_fname; pos_lnum; pos_bol = 0; pos_cnum = end_ }
+ in
+ let location = Location.{ loc_start; loc_end; loc_ghost = false } in
+ LOCATION location }
| _ { raise(Error(Illegal_character)) }
and comment = parse
if !comment_depth > 0 then comment lexbuf }
| eof
{ raise (Error(Unterminated_comment)) }
+ | newline
+ { Lexing.new_line lexbuf; comment lexbuf }
| _
{ comment lexbuf }
| _
{ store_string_char(Lexing.lexeme_char lexbuf 0);
string lexbuf }
+
open Clflags
+let write_asm_file = ref false
let compile_file filename =
+ if !write_asm_file then begin
+ let out_name = Filename.chop_extension filename ^ ".s" in
+ Emitaux.output_channel := open_out out_name
+ end; (* otherwise, stdout *)
Clflags.dlcode := false;
Compilenv.reset ~source_provenance:(Timings.File filename) "test";
Emit.begin_assembly();
let ic = open_in filename in
let lb = Lexing.from_channel ic in
+ lb.Lexing.lex_curr_p <- { lb.Lexing.lex_curr_p with pos_fname = filename };
try
while true do
Asmgen.compile_phrase Format.std_formatter
done
with
End_of_file ->
- close_in ic; Emit.end_assembly()
+ close_in ic; Emit.end_assembly();
+ if !write_asm_file then close_out !Emitaux.output_channel
| Lexcmm.Error msg ->
close_in ic; Lexcmm.report_error lb msg
| Parsing.Parse_error ->
close_in ic;
- prerr_string "Syntax error near character ";
- prerr_int (Lexing.lexeme_start lb);
- prerr_newline()
+ let start_p = Lexing.lexeme_start_p lb in
+ let end_p = Lexing.lexeme_end_p lb in
+ Printf.eprintf "File \"%s\", line %i, characters %i-%i:\n\
+ Syntax error.\n%!"
+ filename
+ start_p.Lexing.pos_lnum
+ (start_p.Lexing.pos_cnum - start_p.Lexing.pos_bol)
+ (end_p.Lexing.pos_cnum - start_p.Lexing.pos_bol)
| Parsecmmaux.Error msg ->
close_in ic; Parsecmmaux.report_error msg
| x ->
let main() =
Arg.parse [
+ "-S", Arg.Set write_asm_file,
+ " Output file to filename.s (default is stdout)";
+ "-g", Arg.Set Clflags.debug, "";
"-dcmm", Arg.Set dump_cmm, "";
+ "-dcse", Arg.Set dump_cse, "";
"-dsel", Arg.Set dump_selection, "";
"-dlive", Arg.Unit(fun () -> dump_live := true;
Printmach.print_live := true), "";
"-dalloc", Arg.Set dump_regalloc, "";
"-dreload", Arg.Set dump_reload, "";
"-dscheduling", Arg.Set dump_scheduling, "";
- "-dlinear", Arg.Set dump_linear, ""
+ "-dlinear", Arg.Set dump_linear, "";
+ "-dtimings", Arg.Set print_timings, "";
] compile_file usage
-let _ = (*Printexc.catch*) main (); exit 0
+let _ = (*Printexc.catch*) Timings.(time All) main ();
+ if !Clflags.print_timings then Timings.print Format.std_formatter;
+ exit 0
List.iter (fun pos -> index.(pos) <- i) posl;
actv.(i) <- e
done;
- Cswitch(selector, index, actv)
+ Cswitch(selector, index, actv, Debuginfo.none)
let access_array base numelt size =
match numelt with
Cconst_int 0 -> base
- | Cconst_int n -> Cop(Cadda, [base; Cconst_int(n * size)])
+ | Cconst_int n -> Cop(Cadda, [base; Cconst_int(n * size)], Debuginfo.none)
| _ -> Cop(Cadda, [base;
- Cop(Clsl, [numelt; Cconst_int(Misc.log2 size)])])
+ Cop(Clsl, [numelt; Cconst_int(Misc.log2 size)],
+ Debuginfo.none)],
+ Debuginfo.none)
%}
%token CATCH
%token CHECKBOUND
%token COLON
+%token DATA
%token DIVF
%token DIVI
%token EOF
%token GEA
%token GEF
%token GEI
+%token GLOBAL
%token GTA
%token GTF
%token GTI
%token LEI
%token LET
%token LOAD
+%token <Location.t> LOCATION
%token LPAREN
%token LSL
%token LSR
| EOF { raise End_of_file }
;
fundecl:
- LPAREN FUNCTION STRING LPAREN params RPAREN sequence RPAREN
+ LPAREN FUNCTION fun_name LPAREN params RPAREN sequence RPAREN
{ List.iter (fun (id, ty) -> unbind_ident id) $5;
{fun_name = $3; fun_args = $5; fun_body = $7; fun_fast = true;
- fun_dbg = Debuginfo.none} }
+ fun_dbg = debuginfo ()} }
;
+fun_name:
+ STRING { $1 }
+ | IDENT { $1 }
params:
oneparam params { $1 :: $2 }
| /**/ { [] }
| LBRACKET RBRACKET { Ctuple [] }
| LPAREN LET letdef sequence RPAREN { make_letdef $3 $4 }
| LPAREN ASSIGN IDENT expr RPAREN { Cassign(find_ident $3, $4) }
- | LPAREN APPLY expr exprlist machtype RPAREN
- { Cop(Capply($5, Debuginfo.none), $3 :: List.rev $4) }
+ | LPAREN APPLY location expr exprlist machtype RPAREN
+ { Cop(Capply $6, $4 :: List.rev $5, debuginfo ?loc:$3 ()) }
| LPAREN EXTCALL STRING exprlist machtype RPAREN
- {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]) }
- | LPAREN binaryop expr expr RPAREN { Cop($2, [$3; $4]) }
+ {Cop(Cextcall($3, $5, false, None), List.rev $4, debuginfo ())}
+ | LPAREN ALLOC exprlist RPAREN { Cop(Calloc, List.rev $3, debuginfo ()) }
+ | LPAREN SUBF expr RPAREN { Cop(Cnegf, [$3], debuginfo ()) }
+ | LPAREN SUBF expr expr RPAREN { Cop(Csubf, [$3; $4], debuginfo ()) }
+ | LPAREN unaryop expr RPAREN { Cop($2, [$3], debuginfo ()) }
+ | LPAREN binaryop expr expr RPAREN { Cop($2, [$3; $4], debuginfo ()) }
| LPAREN SEQ sequence RPAREN { $3 }
| LPAREN IF expr expr expr RPAREN { Cifthenelse($3, $4, $5) }
| LPAREN SWITCH INTCONST expr caselist RPAREN { make_switch $3 $4 $5 }
match $3 with
Cconst_int x when x <> 0 -> $4
| _ -> Cifthenelse($3, $4, (Cexit(0,[]))) in
- Ccatch(0, [], Cloop body, Ctuple []) }
- | LPAREN CATCH sequence WITH sequence RPAREN { Ccatch(0, [], $3, $5) }
+ Ccatch(Recursive, [0, [], Cloop body], Ctuple []) }
+ | LPAREN EXIT IDENT exprlist RPAREN
+ { Cexit(find_label $3, List.rev $4) }
+ | LPAREN CATCH sequence WITH catch_handlers RPAREN
+ { let handlers = $5 in
+ List.iter (fun (_, l, _) -> List.iter unbind_ident l) handlers;
+ Ccatch(Recursive, handlers, $3) }
| EXIT { Cexit(0,[]) }
| LPAREN TRY sequence WITH bind_ident sequence RPAREN
{ unbind_ident $5; Ctrywith($3, $5, $6) }
+ | LPAREN VAL expr expr RPAREN
+ { Cop(Cload (Word_val, Mutable), [access_array $3 $4 Arch.size_addr],
+ debuginfo ()) }
| LPAREN ADDRAREF expr expr RPAREN
- { Cop(Cload Word_val, [access_array $3 $4 Arch.size_addr]) }
+ { Cop(Cload (Word_val, Mutable), [access_array $3 $4 Arch.size_addr],
+ Debuginfo.none) }
| LPAREN INTAREF expr expr RPAREN
- { Cop(Cload Word_int, [access_array $3 $4 Arch.size_int]) }
+ { Cop(Cload (Word_int, Mutable), [access_array $3 $4 Arch.size_int],
+ Debuginfo.none) }
| LPAREN FLOATAREF expr expr RPAREN
- { Cop(Cload Double_u, [access_array $3 $4 Arch.size_float]) }
+ { Cop(Cload (Double_u, Mutable), [access_array $3 $4 Arch.size_float],
+ Debuginfo.none) }
| LPAREN ADDRASET expr expr expr RPAREN
{ Cop(Cstore (Word_val, Assignment),
- [access_array $3 $4 Arch.size_addr; $5]) }
+ [access_array $3 $4 Arch.size_addr; $5], Debuginfo.none) }
| LPAREN INTASET expr expr expr RPAREN
{ Cop(Cstore (Word_int, Assignment),
- [access_array $3 $4 Arch.size_int; $5]) }
+ [access_array $3 $4 Arch.size_int; $5], Debuginfo.none) }
| LPAREN FLOATASET expr expr expr RPAREN
{ Cop(Cstore (Double_u, Assignment),
- [access_array $3 $4 Arch.size_float; $5]) }
+ [access_array $3 $4 Arch.size_float; $5], Debuginfo.none) }
;
exprlist:
exprlist expr { $2 :: $1 }
| FLOAT32 { Single }
| FLOAT64 { Double }
| FLOAT { Double_u }
-
+ | VAL { Word_val }
;
unaryop:
- LOAD chunk { Cload $2 }
- | ALLOC { Calloc Debuginfo.none }
+ LOAD chunk { Cload ($2, Mutable) }
| FLOATOFINT { Cfloatofint }
| INTOFFLOAT { Cintoffloat }
- | RAISE { Craise ($1, Debuginfo.none) }
+ | RAISE { Craise $1 }
| ABSF { Cabsf }
;
binaryop:
STORE chunk { Cstore ($2, Assignment) }
| ADDI { Caddi }
| SUBI { Csubi }
- | MULI { Cmuli }
+ | STAR { Cmuli }
| DIVI { Cdivi }
| MODI { Cmodi }
| AND { Cand }
| LEF { Ccmpf Cle }
| GTF { Ccmpf Cgt }
| GEF { Ccmpf Cge }
- | CHECKBOUND { Ccheckbound Debuginfo.none }
+ | CHECKBOUND { Ccheckbound }
| MULH { Cmulhi }
;
sequence:
;
datadecl:
LPAREN datalist RPAREN { List.rev $2 }
+ | LPAREN DATA datalist RPAREN { List.rev $3 }
;
datalist:
datalist dataitem { $2 :: $1 }
| KSTRING STRING { Cstring $2 }
| SKIP INTCONST { Cskip $2 }
| ALIGN INTCONST { Calign $2 }
+ | GLOBAL STRING { Cglobal_symbol $2 }
;
+catch_handlers:
+ | catch_handler
+ { [$1] }
+ | catch_handler AND catch_handlers
+ { $1 :: $3 }
+
+catch_handler:
+ | sequence
+ { 0, [], $1 }
+ | LPAREN IDENT bind_identlist RPAREN sequence
+ { find_label $2, $3, $5 }
+
+bind_identlist:
+ /**/ { [] }
+ | bind_ident bind_identlist { $1 :: $2 }
+
+location:
+ /**/ { None }
+ | LOCATION { Some $1 }
exception Error of error
let tbl_ident = (Hashtbl.create 57 : (string, Ident.t) Hashtbl.t)
+let tbl_label = (Hashtbl.create 57 : (string, int) Hashtbl.t)
+
+let ident_name s =
+ match String.index s '/' with
+ | exception Not_found -> s
+ | n -> String.sub s 0 n
let bind_ident s =
- let id = Ident.create s in
+ let id = Ident.create (ident_name s) in
Hashtbl.add tbl_ident s id;
id
let unbind_ident id =
Hashtbl.remove tbl_ident (Ident.name id)
+let find_label s =
+ try
+ Hashtbl.find tbl_label s
+ with Not_found ->
+ let lbl = Lambda.next_raise_count () in
+ Hashtbl.add tbl_label s lbl;
+ lbl
+
let report_error = function
Unbound s ->
prerr_string "Unbound identifier "; prerr_string s; prerr_endline "."
+
+let debuginfo ?(loc=Location.symbol_rloc ()) () =
+ Debuginfo.(from_location loc)
val find_ident: string -> Ident.t
val unbind_ident: Ident.t -> unit
+val find_label: string -> int
+
+val debuginfo: ?loc:Location.t -> unit -> Debuginfo.t
+
type error =
Unbound of string
--- /dev/null
+(function "pgcd_30030" (a:int)
+ (catch (exit pgcd a 30030)
+ with (pgcd n m)
+ (if (> n m)
+ (exit pgcd m n)
+ (if (== n 0)
+ m
+ (let (r (mod m n))
+ (exit pgcd r n))))))
\ No newline at end of file
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
+Raised at file "backtrace2.ml", line 8, characters 23-34
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 13, characters 4-11
+Re-raised at file "backtrace2.ml", line 15, characters 68-71
+Called from file "backtrace2.ml", line 58, 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
+Raised at file "backtrace2.ml", line 16, characters 26-37
+Called from file "backtrace2.ml", line 58, 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
+Raised at file "backtrace2.ml", line 8, characters 23-34
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 13, characters 4-11
+Called from file "backtrace2.ml", line 58, characters 11-23
+e
+Uncaught exception Backtrace2.Error("e")
+Raised at file "backtrace2.ml", line 22, characters 56-59
+Called from file "backtrace2.ml", line 58, characters 11-23
+f
+Uncaught exception Backtrace2.Error("f")
+Raised at file "backtrace2.ml", line 28, characters 68-71
+Called from file "backtrace2.ml", line 58, characters 11-23
Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace2.ml", line 18, characters 14-22
+Raised by primitive operation at file "backtrace2.ml", line 58, characters 14-22
+test_Not_found
+Uncaught exception Not_found
+Raised at file "hashtbl.ml", line 194, characters 19-28
+Called from file "backtrace2.ml", line 39, characters 9-42
+Re-raised at file "backtrace2.ml", line 39, characters 67-70
+Called from file "backtrace2.ml", line 58, characters 11-23
+Uncaught exception Not_found
+Raised at file "backtrace2.ml", line 43, characters 24-33
+Called from file "backtrace2.ml", line 43, characters 43-52
+Called from file "backtrace2.ml", line 43, characters 43-52
+Called from file "backtrace2.ml", line 43, characters 43-52
+Called from file "backtrace2.ml", line 43, characters 43-52
+Called from file "backtrace2.ml", line 43, characters 43-52
+Called from file "camlinternalLazy.ml", line 27, characters 17-27
+Re-raised at file "camlinternalLazy.ml", line 34, characters 10-11
+Called from file "backtrace2.ml", line 58, characters 11-23
+Uncaught exception Not_found
+Raised at file "hashtbl.ml", line 194, characters 19-28
+Called from file "backtrace2.ml", line 46, characters 8-41
+Re-raised at file "camlinternalLazy.ml", line 33, characters 62-63
+Called from file "camlinternalLazy.ml", line 27, characters 17-27
+Re-raised at file "camlinternalLazy.ml", line 34, characters 10-11
+Called from file "backtrace2.ml", line 58, characters 11-23
exception Error of string
-let rec f msg n =
- if n = 0 then raise(Error msg) else 1 + f msg (n-1)
-
-let g msg =
+let test_Error msg =
+ let rec f msg n =
+ if n = 0 then raise(Error msg) else 1 + f msg (n-1) in
+ let exception_raised_internally () =
+ try Hashtbl.find (Hashtbl.create 3) 0
+ with Not_found -> false in
try
f msg 5
with Error "a" -> print_string "a"; print_newline(); 0
| Error "b" as exn -> print_string "b"; print_newline(); raise exn
| Error "c" -> raise (Error "c")
+ (** [Error "d"] not caught *)
+ (** Test reraise when an exception is used in the middle of the exception
+ handler. Currently the wrong backtrace is used. *)
+ | Error "e" as exn ->
+ print_string "e"; print_newline ();
+ ignore (exception_raised_internally ()); raise exn
+ (** Test reraise of backtrace when a `when` clause use exceptions.
+ Currently the wrong backtrace is used.
+ *)
+ | Error "f" when exception_raised_internally () ->
+ assert false (** absurd: when false *)
+ | Error "f" as exn -> print_string "f"; print_newline(); raise exn
+
+let test_Not_found () =
+ let rec aux n =
+ if n = 0 then raise Not_found else 1 + aux (n-1)
+ in
+ try aux 5
+ (** Test the raise to reraise heuristic with included try_with.
+ Currently the wrong backtrace is used. *)
+ with exn ->
+ print_string "test_Not_found"; print_newline();
+ (try Hashtbl.find (Hashtbl.create 3) 0 with Not_found -> raise exn)
+
+let test_lazy =
+ let rec aux n =
+ if n = 0 then raise Not_found else 1 + aux (n-1)
+ in
+ let exception_raised_internally () =
+ try Hashtbl.find (Hashtbl.create 3) 0
+ with Not_found -> () in
+ let l = lazy (aux 5) in
+ (** Test the backtrace obtained from a lazy value.
+ Currently the second time the value is forced the
+ wrong backtrace is used. *)
+ fun () ->
+ exception_raised_internally ();
+ Lazy.force l
-let run args =
+let run g args =
try
ignore (g args.(0)); print_string "No exception\n"
with exn ->
let _ =
Printexc.record_backtrace true;
- run [| "a" |];
- run [| "b" |];
- run [| "c" |];
- run [| "d" |];
- run [| |]
+ run test_Error [| "a" |];
+ run test_Error [| "b" |];
+ run test_Error [| "c" |];
+ run test_Error [| "d" |];
+ run test_Error [| "e" |];
+ run test_Error [| "f" |];
+ run test_Error [| |];
+ run test_Not_found [| () |];
+ run test_lazy [| () |];
+ run test_lazy [| () |];
+ ()
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
+Raised at file "backtrace2.ml", line 8, characters 18-34
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 13, characters 4-11
+Re-raised at file "backtrace2.ml", line 15, characters 62-71
+Called from file "backtrace2.ml", line 58, 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
+Raised at file "backtrace2.ml", line 16, characters 20-37
+Called from file "backtrace2.ml", line 58, 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
+Raised at file "backtrace2.ml", line 8, characters 18-34
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 13, characters 4-11
+Called from file "backtrace2.ml", line 58, characters 11-23
+e
+Uncaught exception Backtrace2.Error("e")
+Raised at file "backtrace2.ml", line 22, characters 50-59
+Called from file "backtrace2.ml", line 58, characters 11-23
+f
+Uncaught exception Backtrace2.Error("f")
+Raised at file "backtrace2.ml", line 28, characters 62-71
+Called from file "backtrace2.ml", line 58, characters 11-23
Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace2.ml", line 18, characters 14-22
+Raised by primitive operation at file "backtrace2.ml", line 58, characters 14-22
+test_Not_found
+Uncaught exception Not_found
+Raised at file "hashtbl.ml", line 194, characters 13-28
+Called from file "backtrace2.ml", line 39, characters 9-42
+Re-raised at file "backtrace2.ml", line 39, characters 61-70
+Called from file "backtrace2.ml", line 58, characters 11-23
+Uncaught exception Not_found
+Raised at file "backtrace2.ml", line 43, characters 18-33
+Called from file "backtrace2.ml", line 43, characters 43-52
+Called from file "backtrace2.ml", line 43, characters 43-52
+Called from file "backtrace2.ml", line 43, characters 43-52
+Called from file "backtrace2.ml", line 43, characters 43-52
+Called from file "backtrace2.ml", line 43, characters 43-52
+Called from file "camlinternalLazy.ml", line 27, characters 17-27
+Re-raised at file "camlinternalLazy.ml", line 34, characters 4-11
+Called from file "backtrace2.ml", line 58, characters 11-23
+Uncaught exception Not_found
+Raised at file "hashtbl.ml", line 194, characters 13-28
+Called from file "backtrace2.ml", line 46, characters 8-41
+Re-raised at file "camlinternalLazy.ml", line 33, characters 56-63
+Called from file "camlinternalLazy.ml", line 27, characters 17-27
+Re-raised at file "camlinternalLazy.ml", line 34, characters 4-11
+Called from file "backtrace2.ml", line 58, characters 11-23
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
+Called from file "raw_backtrace.ml", line 16, characters 4-11
+Re-raised at file "raw_backtrace.ml", line 18, characters 68-71
+Called from file "raw_backtrace.ml", line 33, 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
+Raised at file "raw_backtrace.ml", line 19, characters 26-37
+Called from file "raw_backtrace.ml", line 33, 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 11, characters 4-11
-Called from file "raw_backtrace.ml", line 18, characters 11-23
+Called from file "raw_backtrace.ml", line 16, characters 4-11
+Called from file "raw_backtrace.ml", line 33, characters 11-23
+e
+Uncaught exception Raw_backtrace.Error("e")
+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 16, characters 4-11
+Re-raised at file "raw_backtrace.ml", line 25, characters 39-42
+Called from file "raw_backtrace.ml", line 33, characters 11-23
+f
+Uncaught exception Raw_backtrace.Localized(_)
+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 16, characters 4-11
+Re-raised at file "raw_backtrace.ml", line 29, characters 39-54
+Called from file "raw_backtrace.ml", line 33, 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
+Raised by primitive operation at file "raw_backtrace.ml", line 33, characters 14-22
let rec f msg n =
if n = 0 then raise(Error msg) else 1 + f msg (n-1)
+exception Localized of exn
+
let g msg =
+ let exception_raised_internally () =
+ try Hashtbl.find (Hashtbl.create 3) 0
+ with Not_found -> false in
try
f msg 5
with Error "a" -> print_string "a"; print_newline(); 0
| Error "b" as exn -> print_string "b"; print_newline(); raise exn
| Error "c" -> raise (Error "c")
+ (** [Error "d"] not caught *)
+ | Error "e" as exn ->
+ let bt = Printexc.get_raw_backtrace () in
+ print_string "e"; print_newline ();
+ ignore (exception_raised_internally ());
+ Printexc.raise_with_backtrace exn bt
+ | Error "f" as exn ->
+ let bt = Printexc.get_raw_backtrace () in
+ print_string "f"; print_newline ();
+ Printexc.raise_with_backtrace (Localized exn) bt
let backtrace args =
try
try ignore (f "c" 5); assert false with Error _ -> ();
end;
Printf.printf "Uncaught exception %s\n" exn;
- Printexc.print_raw_backtrace stdout trace
+ Printexc.print_raw_backtrace stdout trace;
+ flush stdout
let _ =
Printexc.record_backtrace true;
run [| "b" |];
run [| "c" |];
run [| "d" |];
+ run [| "e" |];
+ run [| "f" |];
run [| |]
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
+Called from file "raw_backtrace.ml", line 16, characters 4-11
+Re-raised at file "raw_backtrace.ml", line 18, characters 62-71
+Called from file "raw_backtrace.ml", line 33, 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
+Raised at file "raw_backtrace.ml", line 19, characters 20-37
+Called from file "raw_backtrace.ml", line 33, 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 11, characters 4-11
-Called from file "raw_backtrace.ml", line 18, characters 11-23
+Called from file "raw_backtrace.ml", line 16, characters 4-11
+Called from file "raw_backtrace.ml", line 33, characters 11-23
+e
+Uncaught exception Raw_backtrace.Error("e")
+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 16, characters 4-11
+Re-raised at file "raw_backtrace.ml", line 25, characters 9-45
+Called from file "raw_backtrace.ml", line 33, characters 11-23
+f
+Uncaught exception Raw_backtrace.Localized(_)
+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 16, characters 4-11
+Re-raised at file "raw_backtrace.ml", line 29, characters 9-57
+Called from file "raw_backtrace.ml", line 33, 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
+Raised by primitive operation at file "raw_backtrace.ml", line 33, characters 14-22
--- /dev/null
+let non_float_array : int array = [| |]
+
+let float_array : float array = [| |]
+
+let non_float_array_from_runtime : int array =
+ Array.make 0 0
+
+let float_array_from_runtime : float array =
+ Array.make 0 0.0
+
+let () =
+ assert (Pervasives.compare non_float_array non_float_array_from_runtime = 0);
+ assert (Pervasives.compare non_float_array non_float_array_from_runtime = 0);
+ assert (Pervasives.compare float_array float_array_from_runtime = 0);
+ assert (Pervasives.compare float_array float_array_from_runtime = 0)
BASEDIR=../..
-MODULES=offset pr6726
+MODULES=offset pr6726 pr7427
MAIN_MODULE=main
include $(BASEDIR)/makefiles/Makefile.one
let () = M.test (Offset.M.Set.singleton "42")
let v = Pr6726.Test.v
+
+(* PR#7427 *)
+
+let () =
+ try
+ let module M = Pr7427.F () in
+ failwith "Test failed"
+ with Assert_failure _ -> ()
--- /dev/null
+module F() = struct
+ module M = struct
+ let aaa = assert false
+ let bbb () = assert false
+ end
+ let ccc () = M.bbb ()
+end
(* PR#6879 *)
let f n = assert (1 mod n = 0)
let () = f 1
+
+
+type t = {x: int; y:int}
+let f x = {x; y = x/0}.x
+let () = try ignore (f 1); assert false with Division_by_zero -> ()
--- /dev/null
+let f x y = Printf.printf "%d %d\n" x y
+
+let i = ref 0
+let () = f (incr i; !i) !i
--- /dev/null
+(* PR#6136 *)
+
+exception Ok
+
+let first () =
+ let f g x = ignore (failwith "called f"); g in
+ let g x = x in
+ f g 2 (raise Ok)
+
+let second () =
+ let f g x = ignore (failwith "called f"); g in
+ let g x = x in
+ let h f = f g 2 (raise Ok) in
+ ignore (h f)
+
+let () =
+ try
+ ignore (first ());
+ assert false
+ with Ok ->
+ try
+ ignore (second ());
+ assert false
+ with Ok -> ()
--- /dev/null
+let i = ref 0
+
+let f x y =
+ Printf.printf "%d %d\n" x y;
+ 0
+[@@inline never]
+
+let foo _ = ()
+
+let foobar baz =
+ let incr_i _ =
+ incr i;
+ !i
+ in
+ let b = !i in
+ let z = foo 42 in
+ let a = (incr_i [@inlined never]) z in
+ let x = f a b in
+ x + 1
+
+let () =
+ ignore ((foobar 0) : int)
--- /dev/null
+(* PR#7531 *)
+
+let f =
+ (let _i = print_endline "first"
+ in fun q -> fun i -> "") (print_endline "x")
+
+let _ =
+ let k =
+ (let _i = print_int 1
+ in fun q -> fun i -> "") ()
+ in k (print_int 0)
+
+let () =
+ print_endline "foo";
+ ignore ((f ()) : string);
+ ignore ((f ()) : string);
+ print_endline "bar"
--- /dev/null
+x
+first
+10foo
+bar
let _ =
begin try raise (G.Exn "foo") with G.Exn s -> print_string s end;
print_int ((new G.c)#m); print_newline()
+
+
+
+include (struct
+ let a = 10
+ module X = struct let x = 1 let z = 42 let y = 2 end
+ exception XXX
+end : sig
+ module X : sig val y: int val x: int end
+ exception XXX
+ val a: int
+end)
+
+let () =
+ Printf.printf "%i / %i / %i \n%!" X.x X.y a;
+ Printf.printf "%s\n%!" (Printexc.to_string XXX)
42
foo1
foo1
+1 / 2 / 10
+XXX
--- /dev/null
+let () =
+ assert(Sys.getenv_opt "FOOBAR_UNLIKELY_TO_EXIST_42" = None);
+
+ assert(int_of_string_opt "foo" = None);
+ assert(int_of_string_opt "42" = Some 42);
+ assert(int_of_string_opt (String.make 100 '9') = None);
+
+ assert(Nativeint.of_string_opt "foo" = None);
+ assert(Nativeint.of_string_opt "42" = Some 42n);
+ assert(Nativeint.of_string_opt (String.make 100 '9') = None);
+
+ assert(Int32.of_string_opt "foo" = None);
+ assert(Int32.of_string_opt "42" = Some 42l);
+ assert(Int32.of_string_opt (String.make 100 '9') = None);
+
+ assert(Int64.of_string_opt "foo" = None);
+ assert(Int64.of_string_opt "42" = Some 42L);
+ assert(Int64.of_string_opt (String.make 100 '9') = None);
+
+ assert(bool_of_string_opt "" = None);
+ assert(bool_of_string_opt "true" = Some true);
+ assert(bool_of_string_opt "false" = Some false);
+
+ assert(float_of_string_opt "foo" = None);
+ assert(float_of_string_opt "42." = Some 42.);
+ assert(float_of_string_opt (String.make 1000 '9') = Some infinity);
+
+ assert(List.nth_opt [] 0 = None);
+ assert(List.nth_opt [42] 0 = Some 42);
+ assert(List.nth_opt [42] 1 = None);
+
+ assert(List.find_opt (fun _ -> true) [] = None);
+ assert(List.find_opt (fun x -> x > 10) [4; 42] = Some 42);
+
+ assert(List.assoc_opt 42 [] = None);
+ assert(List.assoc_opt 42 [41, false; 42, true] = Some true);
+
+ assert(List.assq_opt 42 [] = None);
+ assert(List.assq_opt 42 [41, false; 42, true] = Some true);
+
+ let h = Hashtbl.create 5 in
+ assert(Hashtbl.find_opt h 42 = None);
+ Hashtbl.add h 42 ();
+ assert(Hashtbl.find_opt h 42 = Some ());
+
+
+ let module IntSet = Set.Make(struct
+ type t = int
+ let compare = compare
+ end)
+ in
+ let set = IntSet.of_list [42; 43] in
+ assert(IntSet.min_elt_opt IntSet.empty = None);
+ assert(IntSet.min_elt_opt set = Some 42);
+
+ assert(IntSet.max_elt_opt IntSet.empty = None);
+ assert(IntSet.max_elt_opt set = Some 43);
+
+ assert(IntSet.choose_opt IntSet.empty = None);
+ assert(IntSet.choose_opt set <> None);
+
+ assert(IntSet.find_opt 42 IntSet.empty = None);
+ assert(IntSet.find_opt 42 set = Some 42);
+ assert(IntSet.find_opt 0 set = None);
+
+
+ let module IntMap = Map.Make(struct
+ type t = int
+ let compare = compare
+ end)
+ in
+ let map = IntMap.add 42 "42" (IntMap.add 43 "43" IntMap.empty) in
+ assert(IntMap.min_binding_opt IntMap.empty = None);
+ assert(IntMap.min_binding_opt map = Some (42, "42"));
+
+ assert(IntMap.max_binding_opt IntMap.empty = None);
+ assert(IntMap.max_binding_opt map = Some (43, "43"));
+
+ assert(IntMap.choose_opt IntMap.empty = None);
+ assert(IntMap.choose_opt map <> None);
+
+ assert(IntMap.find_opt 42 IntMap.empty = None);
+ assert(IntMap.find_opt 42 map = Some "42");
+ assert(IntMap.find_opt 0 map = None);
+
+
+ let s = "Hello world !" in
+ assert(String.index_opt s 'x' = None);
+ assert(String.index_opt s ' ' = Some 5);
+
+ assert(String.rindex_opt s 'x' = None);
+ assert(String.rindex_opt s ' ' = Some 11);
+
+ assert(String.index_from_opt s 0 'x' = None);
+ assert(String.index_from_opt s 6 ' ' = Some 11);
+
+ assert(String.rindex_from_opt s 0 'x' = None);
+ assert(String.rindex_from_opt s 6 ' ' = Some 5);
+
+
+ let module W = Weak.Make(struct
+ type t = int ref
+ let equal = (=)
+ let hash = Hashtbl.hash
+ end)
+ in
+ let w = W.create 10 in
+ let x = Random.int 42 in
+ let r = ref x in
+ assert (W.find_opt w r = None);
+ W.add w r;
+ assert (W.find_opt w r = Some r);
+
+ ()
--- /dev/null
+(* PR#7533 *)
+
+exception Foo
+
+let f x =
+ if x > 42 then 1
+ else raise Foo
+
+let () =
+ let f = Sys.opaque_identity f in
+ match (f 0) / (List.hd (Sys.opaque_identity [0])) with
+ | exception Foo -> ()
+ | _ -> assert false
+
+let () =
+ let f = Sys.opaque_identity f in
+ match (f 0) mod (List.hd (Sys.opaque_identity [0])) with
+ | exception Foo -> ()
+ | _ -> assert false
--- /dev/null
+(* Test for optimisation of jump tables to arrays of constants *)
+
+let p = Printf.printf
+
+type test =
+ Test : 'b * 'a * ('b -> 'a) -> test
+
+type t = A | B | C
+
+(* These test functions need to have at least three cases.
+ Functions with fewer cases don't trigger the optimisation,
+ as they are compiled to if-then-else, not switch *)
+let testcases = [
+ Test (3, 3, function 1 -> 1 | 2 -> 2 | 3 -> 3 | _ -> 0);
+ Test (3, -3, function 1 -> 1 | 2 -> 2 | 3 -> -3 | _ -> 0);
+ Test (3, min_int, function 1 -> 1 | 2 -> 2 | 3 -> min_int | _ -> 0);
+ Test (3, max_int, function 1 -> 1 | 2 -> 2 | 3 -> max_int | _ -> 0);
+ Test (3, 3., function 1 -> 1. | 2 -> 2. | 3 -> 3. | _ -> 0.);
+ Test (3, Sys.opaque_identity "c" ^ Sys.opaque_identity "c",
+ function 1 -> "a" | 2 -> "b" | 3 -> "cc" | _ -> "");
+ Test (3, List.rev [3;2;1], function 1 -> [] | 2 -> [42] | 3 -> [1;2;3] | _ -> [415]);
+
+ Test (C, 3, function A -> 1 | B -> 2 | C -> 3);
+ Test (C, -3, function A -> 1 | B -> 2 | C -> -3);
+ Test (C, min_int, function A -> 1 | B -> 2 | C -> min_int);
+ Test (C, max_int, function A -> 1 | B -> 2 | C -> max_int);
+ Test (C, 3., function A -> 1. | B -> 2. | C -> 3.);
+ Test (C, "c", function A -> "a" | B -> "b" | C -> "c");
+ Test (C, List.rev [3;2;1], function A -> [] | B -> [42] | C -> [1;2;3]);
+
+ Test (42, 42, function
+ | 1 -> 1 | 2 -> 2 | 3 -> 3 | 4 -> 4 | 5 -> 5 | 6 -> 6 | 7 -> 7 | 8 -> 8
+ | 9 -> 9 | 10 -> 10 | 11 -> 11 | 12 -> 12 | 13 -> 13 | 14 -> 14 | 15 -> 15
+ | 16 -> 16 | 17 -> 17 | 18 -> 18 | 19 -> 19 | 20 -> 20 | 21 -> 21 | 22 -> 22
+ | 23 -> 23 | 24 -> 24 | 25 -> 25 | 26 -> 26 | 27 -> 27 | 28 -> 28 | 29 -> 29
+ | 30 -> 30 | 31 -> 31 | 32 -> 32 | 33 -> 33 | 34 -> 34 | 35 -> 35 | 36 -> 36
+ | 37 -> 37 | 38 -> 38 | 39 -> 39 | 40 -> 40 | 41 -> 41 | 42 -> 42 | 43 -> 43
+ | 44 -> 44 | 45 -> 45 | 46 -> 46 | 47 -> 47 | 48 -> 48 | 49 -> 49 | 50 -> 50
+ | 51 -> 51 | 52 -> 52 | 53 -> 53 | 54 -> 54 | 55 -> 55 | 56 -> 56 | 57 -> 57
+ | 58 -> 58 | 59 -> 59 | 60 -> 60 | 61 -> 61 | 62 -> 62 | 63 -> 63 | 64 -> 64
+ | 65 -> 65 | 66 -> 66 | 67 -> 67 | 68 -> 68 | 69 -> 69 | 70 -> 70 | 71 -> 71
+ | 72 -> 72 | 73 -> 73 | 74 -> 74 | 75 -> 75 | 76 -> 76 | 77 -> 77 | 78 -> 78
+ | 79 -> 79 | 80 -> 80 | 81 -> 81 | 82 -> 82 | 83 -> 83 | 84 -> 84 | 85 -> 85
+ | 86 -> 86 | 87 -> 87 | 88 -> 88 | 89 -> 89 | 90 -> 90 | 91 -> 91 | 92 -> 92
+ | 93 -> 93 | 94 -> 94 | 95 -> 95 | 96 -> 96 | 97 -> 97 | 98 -> 98 | 99 -> 99
+ | _ -> 0);
+
+ Test (3, `Tertiary, function
+ | 1 -> `Primary
+ | 2 -> `Secondary
+ | 3 -> `Tertiary
+ | n -> invalid_arg "test")
+ ]
+
+let passes = ref 0
+let run_test (Test (a, b, f)) =
+ assert (f a = b);
+ incr passes
+
+let () =
+ List.iter run_test testcases;
+ Printf.printf "%d tests passed\n" !passes
+
--- /dev/null
+16 tests passed
--- /dev/null
+(* Mantis 7201 *)
+
+let f () = 0 [@@inline never]
+
+let () =
+ try
+ ignore ((0 / f ()) : int);
+ assert false
+ with Division_by_zero -> ()
+
+(* Not in Mantis 7201, but related: *)
+
+let () =
+ try
+ ignore ((0 mod f ()) : int);
+ assert false
+ with Division_by_zero -> ()
int fib(int n)
{
value * fib_closure = caml_named_value("fib");
- return Int_val(callback(*fib_closure, Val_int(n)));
+ return Int_val(caml_callback(*fib_closure, Val_int(n)));
}
char * format_result(int n)
{
value * format_result_closure = caml_named_value("format_result");
- return strdup(String_val(callback(*format_result_closure, Val_int(n))));
+ return strdup(String_val(caml_callback(*format_result_closure, Val_int(n))));
}
let set_int2 c = { contents : int = c }
;;
+(* applying a functor to the unpacking of a first-class module *)
+module M() = struct
+ module type String = module type of String
+ let string = (module String : String)
+ module M = Set.Make(val string)
+end ;;
+
(* More exotic: not even found in the manual (up to version 4.00),
but used in some programs found in the wild.
*)
--- /dev/null
+#**************************************************************************
+#* *
+#* 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=../..
+
+ADD_OPTFLAGS=-unbox-closures
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+(* This test attempts to check that unused closures are not deleted
+ during conversion from flambda to clambda. The idea is that there is
+ a direct call to [foo] in [bar] even though the closure for [foo] is
+ not used. This requires [bar] to be have a specialised parameter that
+ would be [foo]'s closure were there any calls to [bar], and for [bar]
+ to not be deleted even though there are no calls to it. Creating such
+ a situation is difficult, and the fact that the following code does so
+ is very fragile. This means two things:
+
+ 1. This code only tests the appropriate property on amd64
+ architectures. Since the code conversion from flambda to
+ clambda is architecture independent, this should be fine
+ as long as the test is run on such an architecture as part
+ of CI.
+
+ 2. It is likely that future changes to flambda will silently cause
+ this test to stop testing the desired property. It would be worth
+ periodically examining the flambda output for the code to check
+ that this test is still worth using.
+*)
+
+let main x =
+ let[@inline never] inner () =
+ let[@inline never] foo y () () () () () () () = x + y in
+ let x1, x2, x3 = x + 1, x + 2, x + 3 in
+ let bar p y () () () =
+ if p then foo y () () () () () () ()
+ else x1 + x2 + x3
+ in
+ let[@inline never] baz0 y () () () () () () () =
+ let y1 = y + 1 in
+ let[@inline never] baz1 () () () () () =
+ bar false y1 () () ()
+ in
+ baz1 () () () () ()
+ in
+ baz0 1 () () () () () () ()
+ in
+ inner ()
ignore (Gc.minor_words () = 0.)
done
+let ignore_useless_args () =
+ let f x _y = int_of_float (cos x) in
+ let rec g a n x =
+ if n = 0
+ then a
+ else g (a + (f [@inlined always]) x (x +. 1.)) (n - 1) x
+ in
+ ignore (g 0 10 5.)
+
let () =
let flambda =
match Sys.getenv "FLAMBDA" with
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;
+ check_noalloc "ignore useless args" ignore_useless_args;
if flambda then begin
check_noalloc "float and int32 record" unbox_record;
(* Benoit's patch did not support %_[nlNL]; test their behavior *)
+(* Ignore OCAMLRUNPARAM=b to be reproducible *)
+Printexc.record_backtrace false;;
+
(* not supported by Printf or Format: fails at runtime *)
let () = Printf.printf "%_n"
;;
-# Exception: Invalid_argument "Printf: bad conversion %_".
+# - : unit = ()
+# Exception: Invalid_argument "Printf: bad conversion %_".
# Exception: Invalid_argument "Printf: bad conversion %_".
# Exception: Invalid_argument "Printf: bad conversion %_".
# Exception: Invalid_argument "Printf: bad conversion %_".
#**************************************************************************
BASEDIR=../..
-MAIN_MODULE=testarg
-include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.several
include $(BASEDIR)/makefiles/Makefile.common
let error s = Printf.printf "error (%s)\n" s;;
let check r v msg = if !r <> v then error msg;;
-let test argv =
+let test spec argv =
current := 0;
r_set := false;
r_clear := true;
r_int := 0;
r_float := 0.0;
accum := [];
- Arg.parse_argv ~current argv spec f_anon "usage";
+ Arg.parse_and_expand_argv_dynamic current argv (ref spec) f_anon "usage";
let result = List.rev !accum in
let reference = [
"anon(anon1)";
check r_float 2.72 "Set_float";
;;
-test args1;;
-test args2;;
+let test_arg args = test spec (ref args);;
+
+test_arg args1;;
+test_arg args2;;
+
+
+let safe_rm file =
+ try
+ Sys.remove file
+ with _ -> ()
+
+let test_rw argv =
+ safe_rm "test_rw";
+ safe_rm "test_rw0";
+ Arg.write_arg "test_rw" argv;
+ Arg.write_arg0 "test_rw0" argv;
+ let argv' = Arg.read_arg "test_rw" in
+ let argv0 = Arg.read_arg0 "test_rw0" in
+ let f x y =
+ if x <> y then
+ Printf.printf "%20s %c %-20s\n%!" x (if x = y then '=' else '#') y
+ in
+ Array.iter2 f argv argv';
+ Array.iter2 f argv argv0;
+ safe_rm "test_rw";
+ safe_rm "test_rw0";
+;;
+
+test_rw args1;;
+test_rw args2;;
+test_rw (Array.make 0 "");;
+test_rw [|"";""|];;
+
+let f_expand r msg arg s =
+ if s <> r then error msg;
+ arg;
+;;
+
+let expand1,args1,expected1 =
+ let l = Array.length args1 - 1 in
+ let args = Array.sub args1 1 l in
+ let args1 = [|"prog";"-expand";"expand_arg1"|] in
+ Arg.["-expand", Expand (f_expand "expand_arg1" "Expand" args), "Expand (1)";],
+ args1,
+ Array.append args1 args
+;;
+
+let expand2,args2,expected2 =
+ let l = Array.length args2 - 1 in
+ let args = Array.sub args2 1 l in
+ let args2 = [|"prog";"-expand";"expand_arg2"|] in
+ Arg.["-expand", Expand (f_expand "expand_arg2" "Expand" args), "Expand (1)";],
+ args2,
+ Array.append args2 args
+;;
+
+let test_expand spec argv reference =
+ let result = ref argv in
+ test spec result;
+ let f x y =
+ if x <> y then
+ Printf.printf "%20s %c %-20s\n%!" x (if x = y then '=' else '#') y
+ in
+ Array.iter2 f !result reference;
+;;
+
+test_expand (expand1@spec) args1 expected1;;
+test_expand (expand2@spec) args2 expected2;;
--- /dev/null
+(** Test that the right message errors are emitted by Arg *)
+
+
+let usage= "Arg module testing"
+
+let test total i (spec,anon,argv) =
+ let argv = Array.of_list ("testerror" :: argv) in
+ try Arg.parse_argv ~current:(ref 0) argv spec anon usage with
+ | Arg.Bad s-> Printf.printf "(%d/%d) Bad:\n%s\n" (i+1) total s
+ | Arg.Help s -> Printf.printf "(%d/%d) Help:\n%s\n" (i+1) total s
+
+
+let tests = [
+(** missing argument error *)
+ ["-s", Arg.String ignore, "missing arg"], ignore, ["-s"]
+
+(** No argument expected *)
+; ["-set", Arg.Set (ref false), "no argument expected"], ignore, ["-set=true"]
+
+(** help message *)
+; [], ignore, ["-help" ]
+
+(** wrong argument type *)
+; ["-int", Arg.Int ignore, "wrong argument type" ], ignore, ["-int"; "not_an_int" ]
+
+(** unknown option *)
+; [], ignore, [ "-an-unknown-option" ]
+
+(** user-error in anon fun *)
+; [], (fun _ -> raise @@ Arg.Bad("User-raised error")), [ "argument" ]
+
+(** user-error in anon fun *)
+; ["-error",
+ Arg.Unit (fun () -> raise @@ Arg.Bad("User-raised error bis")),
+ "user raised error"]
+, ignore, [ "-error" ]
+]
+
+let () =
+ let n = List.length tests in
+ List.iteri (test n) tests
--- /dev/null
+(1/7) Bad:
+testerror: option '-s' needs an argument.
+Arg module testing
+ -s missing arg
+ -help Display this list of options
+ --help Display this list of options
+
+(2/7) Bad:
+testerror: wrong argument 'true'; option '-set=true' expects no argument.
+Arg module testing
+ -set no argument expected
+ -help Display this list of options
+ --help Display this list of options
+
+(3/7) Help:
+Arg module testing
+ -help Display this list of options
+ --help Display this list of options
+
+(4/7) Bad:
+testerror: wrong argument 'not_an_int'; option '-int' expects an integer.
+Arg module testing
+ -int wrong argument type
+ -help Display this list of options
+ --help Display this list of options
+
+(5/7) Bad:
+testerror: unknown option '-an-unknown-option'.
+Arg module testing
+ -help Display this list of options
+ --help Display this list of options
+
+(6/7) Bad:
+testerror: User-raised error.
+Arg module testing
+ -help Display this list of options
+ --help Display this list of options
+
+(7/7) Bad:
+testerror: User-raised error bis.
+Arg module testing
+ -error user raised error
+ -help Display this list of options
+ --help Display this list of options
+
--- /dev/null
+#**************************************************************************
+#* *
+#* 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=../..
+LIBRARIES=unix bigarray
+ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix \
+ -I $(OTOPDIR)/otherlibs/bigarray
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/bigarray
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+open Bigarray
+
+(* Test harness *)
+
+let error_occurred = ref false
+
+let function_tested = ref ""
+
+let testing_function s =
+ function_tested := s;
+ print_newline();
+ print_string s;
+ print_newline()
+
+let test test_number answer correct_answer =
+ flush stdout;
+ flush stderr;
+ if answer <> correct_answer then begin
+ Printf.eprintf "*** Bad result (%s, test %d)\n" !function_tested test_number;
+ flush stderr;
+ error_occurred := true
+ end else begin
+ Printf.printf " %d..." test_number
+ end
+
+(* Tests *)
+
+let tests () =
+ testing_function "map_file";
+ let mapped_file = Filename.temp_file "bigarray" ".data" in
+ begin
+ let fd =
+ Unix.openfile mapped_file
+ [Unix.O_RDWR; Unix.O_TRUNC; Unix.O_CREAT] 0o666 in
+ let a =
+ array1_of_genarray (Genarray.map_file fd float64 c_layout true [|10000|])
+ in
+ Unix.close fd;
+ for i = 0 to 9999 do a.{i} <- float i done;
+ let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
+ let b =
+ array2_of_genarray
+ (Genarray.map_file fd float64 fortran_layout false [|100; -1|])
+ in
+ Unix.close fd;
+ let ok = ref true in
+ for i = 0 to 99 do
+ for j = 0 to 99 do
+ if b.{j+1,i+1} <> float (100 * i + j) then ok := false
+ done
+ done;
+ test 1 !ok true;
+ b.{50,50} <- (-1.0);
+ let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
+ let c =
+ array2_of_genarray (Genarray.map_file fd float64 c_layout false [|-1; 100|])
+ in
+ Unix.close fd;
+ let ok = ref true in
+ for i = 0 to 99 do
+ for j = 0 to 99 do
+ if c.{i,j} <> float (100 * i + j) then ok := false
+ done
+ done;
+ test 2 !ok true;
+ let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
+ let c =
+ array2_of_genarray
+ (Genarray.map_file fd ~pos:800L float64 c_layout false [|-1; 100|])
+ in
+ Unix.close fd;
+ let ok = ref true in
+ for i = 1 to 99 do
+ for j = 0 to 99 do
+ if c.{i-1,j} <> float (100 * i + j) then ok := false
+ done
+ done;
+ test 3 !ok true;
+ let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
+ let c =
+ array2_of_genarray
+ (Genarray.map_file fd ~pos:79200L float64 c_layout false [|-1; 100|])
+ in
+ Unix.close fd;
+ let ok = ref true in
+ for j = 0 to 99 do
+ if c.{0,j} <> float (100 * 99 + j) then ok := false
+ done;
+ test 4 !ok true
+ end;
+ (* Force garbage collection of the mapped bigarrays above, otherwise
+ Win32 doesn't let us erase the file. Notice the begin...end above
+ so that the VM doesn't keep stack references to the mapped bigarrays. *)
+ Gc.full_major();
+ Sys.remove mapped_file;
+
+ ()
+ [@@inline never]
+
+
+(********* End of test *********)
+
+let _ =
+ tests ();
+ print_newline();
+ if !error_occurred then begin
+ prerr_endline "************* TEST FAILED ****************"; exit 2
+ end else
+ exit 0
--- /dev/null
+
+map_file
+ 1... 2... 3... 4...
Complex.i 1 1);
test 12 true (test_blit_fill complex64 [Complex.zero; Complex.one; Complex.i]
Complex.i 1 1);
+ testing_function "slice";
+ let a = Array1.of_array int c_layout [| 5; 4; 3 |] in
+ test 1 (Array1.slice a 0) (Array0.of_value int c_layout 5);
+ test 2 (Array1.slice a 1) (Array0.of_value int c_layout 4);
+ test 3 (Array1.slice a 2) (Array0.of_value int c_layout 3);
+ let a = Array1.of_array int fortran_layout [| 5; 4; 3 |] in
+ test 6 (Array1.slice a 1) (Array0.of_value int fortran_layout 5);
+ test 7 (Array1.slice a 2) (Array0.of_value int fortran_layout 4);
+ test 8 (Array1.slice a 3) (Array0.of_value int fortran_layout 3);
+
(* Bi-dimensional arrays *)
let a = Genarray.create int c_layout [|2;2;2;2;2|] in
test 1 (Genarray.size_in_bytes a) (32 * (kind_size_in_bytes int));
+(* Zero-dimensional arrays *)
+ testing_function "------ Array0 --------";
+ testing_function "create/set/get";
+ let test_setget kind vals =
+ List.for_all (fun (v1, v2) ->
+ let ca = Array0.create kind c_layout in
+ let fa = Array0.create kind fortran_layout in
+ Array0.set ca v1;
+ Array0.set fa v1;
+ Array0.get ca = v2 && Array0.get fa = v2) vals in
+ test 1 true
+ (test_setget int8_signed
+ [0, 0;
+ 123, 123;
+ -123, -123;
+ 456, -56;
+ 0x101, 1]);
+ test 2 true
+ (test_setget int8_unsigned
+ [0, 0;
+ 123, 123;
+ -123, 133;
+ 456, 0xc8;
+ 0x101, 1]);
+ test 3 true
+ (test_setget int16_signed
+ [0, 0;
+ 123, 123;
+ -123, -123;
+ 31456, 31456;
+ -31456, -31456;
+ 65432, -104;
+ 0x10001, 1]);
+ test 4 true
+ (test_setget int16_unsigned
+ [0, 0;
+ 123, 123;
+ -123, 65413;
+ 31456, 31456;
+ -31456, 34080;
+ 65432, 65432;
+ 0x10001, 1]);
+ test 5 true
+ (test_setget int
+ [0, 0;
+ 123, 123;
+ -456, -456;
+ max_int, max_int;
+ min_int, min_int;
+ 0x12345678, 0x12345678;
+ -0x12345678, -0x12345678]);
+ test 6 true
+ (test_setget int32
+ [Int32.zero, Int32.zero;
+ Int32.of_int 123, Int32.of_int 123;
+ Int32.of_int (-456), Int32.of_int (-456);
+ Int32.max_int, Int32.max_int;
+ Int32.min_int, Int32.min_int;
+ Int32.of_string "0x12345678", Int32.of_string "0x12345678"]);
+ test 7 true
+ (test_setget int64
+ [Int64.zero, Int64.zero;
+ Int64.of_int 123, Int64.of_int 123;
+ Int64.of_int (-456), Int64.of_int (-456);
+ Int64.max_int, Int64.max_int;
+ Int64.min_int, Int64.min_int;
+ Int64.of_string "0x123456789ABCDEF0",
+ Int64.of_string "0x123456789ABCDEF0"]);
+ test 8 true
+ (test_setget nativeint
+ [Nativeint.zero, Nativeint.zero;
+ Nativeint.of_int 123, Nativeint.of_int 123;
+ Nativeint.of_int (-456), Nativeint.of_int (-456);
+ Nativeint.max_int, Nativeint.max_int;
+ Nativeint.min_int, Nativeint.min_int;
+ Nativeint.of_string "0x12345678",
+ Nativeint.of_string "0x12345678"]);
+ test 9 true
+ (test_setget float32
+ [0.0, 0.0;
+ 4.0, 4.0;
+ -0.5, -0.5;
+ 655360.0, 655360.0]);
+ test 10 true
+ (test_setget float64
+ [0.0, 0.0;
+ 4.0, 4.0;
+ -0.5, -0.5;
+ 1.2345678, 1.2345678;
+ 3.1415e10, 3.1415e10]);
+ test 11 true
+ (test_setget complex32
+ [Complex.zero, Complex.zero;
+ Complex.one, Complex.one;
+ Complex.i, Complex.i;
+ {im = 0.5; re = -2.0}, {im = 0.5; re = -2.0}]);
+ test 12 true
+ (test_setget complex64
+ [Complex.zero, Complex.zero;
+ Complex.one, Complex.one;
+ Complex.i, Complex.i;
+ {im=0.5;re= -2.0}, {im=0.5;re= -2.0};
+ {im=3.1415;re=1.2345678}, {im=3.1415;re=1.2345678}]);
+
+
(* Kind size *)
testing_function "kind_size_in_bytes";
let arr1 = Array1.create Float32 c_layout 1 in
test 5 (Array2.slice_right d 1) (from_list_fortran int [1001;2001;3001;1002]);
test 6 (Array2.slice_right d 2) (from_list_fortran int [2002;3002;1003;2003]);
test 7 (Array2.slice_right d 3) (from_list_fortran int [3003;1004;2004;3004]);
+ testing_function "reshape";
+ let a = make_array2 int c_layout 0 1 1 (fun i -> i + 3) in
+ let b = reshape_0 (genarray_of_array2 a) in
+ let c = reshape (genarray_of_array0 b) [|1|] in
+ test 8 (Array0.get b) 3;
+ test 9 (Genarray.get c [|0|]) 3;
+ test 10 (Genarray.get (Genarray.slice_left c [|0|]) [||]) 3;
(* I/O *)
1... 2... 3... 4... 5... 6... 7... 8... 9...
blit, fill
1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12...
+slice
+ 1... 2... 3... 6... 7... 8...
------ Array2 --------
1... 2... 3... 4... 5... 6... 7...
size_in_bytes_general
1...
+------ Array0 --------
+
+create/set/get
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12...
kind_size_in_bytes
1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13...
1... 2...
reshape_2
1... 2... 3... 4... 5... 6... 7...
+reshape
+ 8... 9... 10...
------ I/O --------
--- /dev/null
+
+
+(** check that custom block are not copied by Weak.get_copy *)
+
+open Bigarray
+open Bigarray.Array1
+
+let () =
+ let a = ref (create float64 c_layout 10) in
+ Gc.compact ();
+ set !a 0 42.;
+
+ let w = Weak.create 1 in
+ Weak.set w 0 (Some !a);
+
+ let b =
+ match Weak.get_copy w 0 with
+ | None -> assert false
+ | Some b -> b
+ in
+ Printf.printf "a.(0) = %f\n" (get !a 0);
+ Printf.printf "b.(0) = %f\n" (get b 0);
+ a := create float64 c_layout 10;
+ Gc.compact ();
+
+ let c = create float64 c_layout 10 in
+ set c 0 33.;
+ Printf.printf "b.(0) = %f\n" (get b 0);
--- /dev/null
+a.(0) = 42.000000
+b.(0) = 42.000000
+b.(0) = 42.000000
--- /dev/null
+#**************************************************************************
+#* *
+#* 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
--- /dev/null
+open Printf
+;;
+
+(* Set up*)
+let n = 10
+;;
+
+let buf = Buffer.create n
+;;
+
+let () =
+ for i = 1 to 10 do
+ Buffer.add_char buf 'a'
+ done
+;;
+
+assert (Buffer.length buf = n)
+;;
+
+(* Helpers *)
+
+let output result str =
+ print_string ("Buffer " ^ str ^ " " ^ result ^ "\n")
+;;
+
+let passed = output "passed"
+;;
+
+let failed = output "failed"
+;;
+
+(* Tests *)
+let () = print_string "Standard Library: Module Buffer\n"
+;;
+
+let truncate_neg : unit =
+ let msg = "truncate: negative" in
+ try
+ Buffer.truncate buf (-1);
+ failed msg
+ with
+ Invalid_argument "Buffer.truncate" ->
+ passed msg
+;;
+
+let truncate_large : unit =
+ let msg = "truncate: large" in
+ try
+ Buffer.truncate buf (n+1);
+ failed msg
+ with
+ Invalid_argument "Buffer.truncate" ->
+ passed msg
+;;
+
+let truncate_correct : unit =
+ let n' = n - 1
+ and msg = "truncate: in-range" in
+ try
+ Buffer.truncate buf n';
+ if Buffer.length buf = n' then
+ passed msg
+ else
+ failed msg
+ with
+ Invalid_argument "Buffer.truncate" ->
+ failed msg
+;;
+
+let reset_non_zero : unit =
+ let msg = "reset: non-zero" in
+ Buffer.reset buf;
+ if Buffer.length buf = 0 then
+ passed msg
+ else
+ failed msg
+;;
+
+let reset_zero : unit =
+ let msg = "reset: zero" in
+ Buffer.reset buf;
+ if Buffer.length buf = 0 then
+ passed msg
+ else
+ failed msg
+;;
--- /dev/null
+Standard Library: Module Buffer
+Buffer truncate: negative passed
+Buffer truncate: large passed
+Buffer truncate: in-range passed
+Buffer reset: non-zero passed
+Buffer reset: zero passed
--- /dev/null
+#**************************************************************************
+#* *
+#* 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=testing
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+let test_raises_invalid_argument f x =
+ ignore
+ (Testing.test_raises_exc_p (function Invalid_argument _ -> true | _ -> false)
+ f x)
+
+let check b offset s =
+ let rec loop i =
+ i = String.length s ||
+ Bytes.get b (i + offset) = String.get s i && loop (i+1)
+ in
+ loop 0
+
+let () =
+ let abcde = Bytes.of_string "abcde" in
+ let open Bytes in
+ begin
+ (*
+ abcde
+ ?????
+ *)
+ Testing.test
+ (length (extend abcde 7 (-7)) = 5);
+
+ (*
+ abcde
+ ?????
+ *)
+ Testing.test
+ (length (extend abcde (-7) 7) = 5);
+
+ (*
+ abcde
+ abcde
+ *)
+ Testing.test
+ (let r = extend abcde 0 0 in
+ length r = 5 && check r 0 "abcde"
+ && r != abcde);
+
+ (*
+ abcde
+ ??abc
+ *)
+ Testing.test
+ (let r = extend abcde 2 (-2) in
+ length r = 5 && check r 2 "abc");
+
+ (*
+ abcde
+ bcd
+ *)
+ Testing.test
+ (let r = extend abcde (-1) (-1) in
+ length r = 3 && check r 0 "bcd");
+
+ (*
+ abcde
+ de??
+ *)
+ Testing.test
+ (let r = extend abcde (-3) 2 in
+ length r = 4 && check r 0 "de");
+
+ (*
+ abcde
+ abc
+ *)
+ Testing.test
+ (let r = extend abcde 0 (-2) in
+ length r = 3 && check r 0 "abc");
+
+ (*
+ abcde
+ cde
+ *)
+ Testing.test
+ (let r = extend abcde (-2) 0 in
+ length r = 3 && check r 0 "cde");
+
+ (*
+ abcde
+ abcde??
+ *)
+ Testing.test
+ (let r = extend abcde 0 2 in
+ length r = 7
+ && check r 0 "abcde");
+
+ (*
+ abcde
+ ??abcde
+ *)
+ Testing.test
+ (let r = extend abcde 2 0 in
+ length r = 7
+ && check r 2 "abcde");
+
+ (*
+ abcde
+ ?abcde?
+ *)
+ Testing.test
+ (let r = extend abcde 1 1 in
+ length r = 7
+ && check r 1 "abcde");
+
+ (* length + left + right < 0 *)
+ test_raises_invalid_argument
+ (fun () -> extend abcde (-3) (-3)) ();
+
+ (* length + left > max_int *)
+ test_raises_invalid_argument
+ (fun () -> extend abcde max_int 0) ();
+
+ (* length + right > max_int *)
+ test_raises_invalid_argument
+ (fun () -> extend abcde 0 max_int) ();
+
+ (* length + left + right > max_int *)
+ test_raises_invalid_argument
+ (fun () -> extend abcde max_int max_int) ();
+ end
--- /dev/null
+ 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14
+All tests succeeded.
#**************************************************************************
BASEDIR=../..
-CSC_COMMAND=csc
+# Only run this test for TOOLCHAIN=msvc
+CSC_COMMAND=$(filter csc,$(subst msvc,csc,$(TOOLCHAIN)))
CSC=$(CSC_COMMAND) $(CSC_FLAGS)
COMPFLAGS=-I $(OTOPDIR)/otherlibs/bigarray -I $(OTOPDIR)/otherlibs/dynlink \
prepare:
@if $(SUPPORTS_SHARED_LIBRARIES); then \
$(OCAMLC) -c plugin.ml && \
- $(OCAMLOPT) -o plugin.cmxs -shared plugin.ml; \
+ if $(BYTECODE_ONLY) ; then : ; else \
+ $(OCAMLOPT) -o plugin.cmxs -shared plugin.ml; \
+ fi; \
fi
.PHONY: bytecode
@mv plugin.cmx.bak plugin.cmx
sub/api.so: sub/api.cmi sub/api.ml
- @cd sub; $(OCAMLOPT) -c $(SHARED) api.ml
+ @cd sub; $(OCAMLOPT) -c $(SUPPORTS_SHARED_LIBRARIES) api.ml
sub/api.cmi: sub/api.mli
@cd sub; $(OCAMLOPT) -c -opaque api.mli
let add = Hashtbl.add
let remove = Hashtbl.remove
let find = Hashtbl.find
+ let find_opt = Hashtbl.find_opt
let find_all = Hashtbl.find_all
let replace = Hashtbl.replace
let mem = Hashtbl.mem
value marshal_to_block(value vbuf, value vlen, value v, value vflags)
{
- return Val_long(output_value_to_block(v, vflags,
+ return Val_long(caml_output_value_to_block(v, vflags,
(char *) vbuf, Long_val(vlen)));
}
value marshal_from_block(value vbuf, value vlen)
{
- return input_value_from_block((char *) vbuf, Long_val(vlen));
+ return caml_input_value_from_block((char *) vbuf, Long_val(vlen));
}
with Not_found ->
M.is_empty s1);
+ checkbool "find_first"
+ (let (l, p, r) = M.split x s1 in
+ if p = None && M.is_empty r then
+ try
+ let _ = M.find_first (fun k -> k >= x) s1 in
+ false
+ with Not_found ->
+ true
+ else
+ let (k, v) = M.find_first (fun k -> k >= x) s1 in
+ match p with
+ None -> (k, v) = M.min_binding r
+ | Some v1 -> (k, v) = (x, v1));
+
+ checkbool "find_first_opt"
+ (let (l, p, r) = M.split x s1 in
+ if p = None && M.is_empty r then
+ match M.find_first_opt (fun k -> k >= x) s1 with
+ None -> true
+ | _ -> false
+ else
+ let Some (k, v) = M.find_first_opt (fun k -> k >= x) s1 in
+ match p with
+ None -> (k, v) = M.min_binding r
+ | Some v1 -> (k, v) = (x, v1));
+
+ checkbool "find_last"
+ (let (l, p, r) = M.split x s1 in
+ if p = None && M.is_empty l then
+ try
+ let _ = M.find_last (fun k -> k <= x) s1 in
+ false
+ with Not_found ->
+ true
+ else
+ let (k, v) = M.find_last (fun k -> k <= x) s1 in
+ match p with
+ None -> (k, v) = M.max_binding l
+ | Some v1 -> (k, v) = (x, v1));
+
+ checkbool "find_last_opt"
+ (let (l, p, r) = M.split x s1 in
+ if p = None && M.is_empty l then
+ match M.find_last_opt (fun k -> k <= x) s1 with
+ None -> true
+ | _ -> false
+ else
+ let Some (k, v) = M.find_last_opt (fun k -> k <= x) s1 in
+ match p with
+ None -> (k, v) = M.max_binding l
+ | Some v1 -> (k, v) = (x, v1));
+
check "split"
(let (l, p, r) = M.split x s1 in
fun i ->
with Not_found ->
S.is_empty s1);
+ checkbool "find_first"
+ (let (l, p, r) = S.split x s1 in
+ if not p && S.is_empty r then
+ try
+ let _ = S.find_first (fun k -> k >= x) s1 in
+ false
+ with Not_found ->
+ true
+ else
+ let e = S.find_first (fun k -> k >= x) s1 in
+ if p then
+ e = x
+ else
+ e = S.min_elt r);
+
+ checkbool "find_first_opt"
+ (let (l, p, r) = S.split x s1 in
+ if not p && S.is_empty r then
+ match S.find_first_opt (fun k -> k >= x) s1 with
+ None -> true
+ | _ -> false
+ else
+ let Some e = S.find_first_opt (fun k -> k >= x) s1 in
+ if p then
+ e = x
+ else
+ e = S.min_elt r);
+
+ checkbool "find_last"
+ (let (l, p, r) = S.split x s1 in
+ if not p && S.is_empty l then
+ try
+ let _ = S.find_last (fun k -> k <= x) s1 in
+ false
+ with Not_found ->
+ true
+ else
+ let e = S.find_last (fun k -> k <= x) s1 in
+ if p then
+ e = x
+ else
+ e = S.max_elt l);
+
+ checkbool "find_last_opt"
+ (let (l, p, r) = S.split x s1 in
+ if not p && S.is_empty l then
+ match S.find_last_opt (fun k -> k <= x) s1 with
+ None -> true
+ | _ -> false
+ else
+ let Some e = S.find_last_opt (fun k -> k <= x) s1 in
+ if p then
+ e = x
+ else
+ e = S.max_elt l);
+
check "split"
(let (l, p, r) = S.split x s1 in
fun i ->
for i = 1 to 10 do s1 := S.add i !s1 done;
let s2 = S.filter (fun e -> e >= 0) !s1 in
assert (s2 == !s1)
+
+let valid_structure s =
+ (* this test should return 'true' for all set,
+ but it can detect sets that are ill-structured,
+ for example incorrectly ordered, as the S.mem
+ function will make assumptions about the set ordering.
+
+ (This trick was used to exhibit the bug in PR#7403)
+ *)
+ List.for_all (fun n -> S.mem n s) (S.elements s)
+
+let () =
+ (* PR#7403: map buggily orders elements according to the input
+ set order, not the output set order. Mapping functions that
+ change the value ordering thus break the set structure. *)
+ let test = S.of_list [1; 3; 5] in
+ let f = function 3 -> 8 | n -> n in
+ assert (valid_structure (S.map f test))
--- /dev/null
+#**************************************************************************
+#* *
+#* 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. *
+#* *
+#**************************************************************************
+ADD_COMPFLAGS=-nolabels
+BASEDIR=../..
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+module A : module type of Array = ArrayLabels
+module B : module type of Bytes = BytesLabels
+module L : module type of List = ListLabels
+module S : module type of String = StringLabels
+
+module M : module type of Map = MoreLabels.Map
+module Se : module type of Set = MoreLabels.Set
+
+
+(* For *)
+(* module H : module type of Hashtbl = MoreLabels.Hashtbl *)
+(* we will have following error: *)
+(* Error: Signature mismatch: *)
+(* ... *)
+(* Type declarations do not match: *)
+(* type statistics = Hashtbl.statistics *)
+(* is not included in *)
+(* type statistics = { *)
+(* num_bindings : int; *)
+(* num_buckets : int; *)
+(* max_bucket_length : int; *)
+(* bucket_histogram : int array; *)
+(* } *)
+(* Their kinds differ. *)
+(* This is workaround:*)
+module Indirection = struct
+ type t = Hashtbl.statistics = { num_bindings: int;
+ num_buckets: int;
+ max_bucket_length: int;
+ bucket_histogram: int array}
+end
+module type HS = sig
+ type statistics = Indirection.t
+ include module type of Hashtbl
+ with type statistics := Indirection.t
+end
+module H : HS = MoreLabels.Hashtbl
+
+let () =
+ ()
--- /dev/null
+
+let () = Printexc.record_backtrace true
+
+let () =
+ let bt =
+ try
+ Hashtbl.find (Hashtbl.create 1) 1;
+ assert false
+ with Not_found ->
+ Printexc.get_raw_backtrace ()
+ in
+ let t = Thread.create (fun () ->
+ try
+ Printexc.raise_with_backtrace Not_found bt
+ with Not_found -> ()
+ ) () in
+ Thread.join t;
+ flush stdout
assert (Uchar.(compare max min) = 1);
()
-let test_dump () =
- let str u = Format.asprintf "%a" Uchar.dump u in
- assert (str Uchar.min = "U+0000");
- assert (str Uchar.(succ min) = "U+0001");
- assert (str Uchar.(of_int 0xFFFF) = "U+FFFF");
- assert (str Uchar.(succ (of_int 0xFFFF)) = "U+10000");
- assert (str Uchar.(pred max) = "U+10FFFE");
- assert (str Uchar.max = "U+10FFFF");
- ()
-
let tests () =
test_constants ();
test_succ ();
test_to_char ();
test_equal ();
test_compare ();
- test_dump ();
()
let () =
--- /dev/null
+#**************************************************************************
+#* *
+#* 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=../..
+LIBRARIES=unix
+ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+
+ifeq ($(OS),Windows_NT)
+ADD_BYTERUN_FLAGS="-I $(OTOPDIR)/otherlibs/win32unix"
+endif
+
+default: reflector.exe fdstatus.exe cmdline_prog.exe
+ @$(MAKE) check
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
+
+%.exe: %.c
+ifeq ($(CCOMPTYPE),msvc)
+ @set -o pipefail ; $(BYTECC) /Fe$*.exe $*.c | tail -n +2
+else
+ @$(BYTECC) -o $*.exe $*.c
+endif
--- /dev/null
+(* This is a terrible hack that plays on the internal representation
+ of file descriptors. The result is a number (as a string)
+ that the fdstatus.exe auxiliary program can use to check whether
+ the fd is open. *)
+
+let string_of_fd (fd: Unix.file_descr) : string =
+ match Sys.os_type with
+ | "Unix" | "Cygwin" -> string_of_int (Obj.magic fd : int)
+ | "Win32" ->
+ if Sys.word_size = 32 then
+ Int32.to_string (Obj.magic fd : int32)
+ else
+ Int64.to_string (Obj.magic fd : int64)
+ | _ -> assert false
+
+let _ =
+ let f0 = Unix.(openfile "tmp.txt" [O_WRONLY; O_CREAT; O_TRUNC] 0o600) in
+ let f1 = Unix.(openfile "tmp.txt" [O_RDONLY; O_KEEPEXEC] 0) in
+ let f2 = Unix.(openfile "tmp.txt" [O_RDONLY; O_CLOEXEC] 0) in
+ let d0 = Unix.dup f0 in
+ let d1 = Unix.dup ~cloexec:false f1 in
+ let d2 = Unix.dup ~cloexec:true f2 in
+ let (p0, p0') = Unix.pipe () in
+ let (p1, p1') = Unix.pipe ~cloexec:false () in
+ let (p2, p2') = Unix.pipe ~cloexec:true () in
+ let s0 = Unix.(socket PF_INET SOCK_STREAM 0) in
+ let s1 = Unix.(socket ~cloexec:false PF_INET SOCK_STREAM 0) in
+ let s2 = Unix.(socket ~cloexec:true PF_INET SOCK_STREAM 0) in
+ let (x0, x0') =
+ try Unix.(socketpair PF_UNIX SOCK_STREAM 0)
+ with Invalid_argument _ -> (p0, p0') in
+ (* socketpair not available under Win32; keep the same output *)
+ let (x1, x1') =
+ try Unix.(socketpair ~cloexec:false PF_UNIX SOCK_STREAM 0)
+ with Invalid_argument _ -> (p1, p1') in
+ let (x2, x2') =
+ try Unix.(socketpair ~cloexec:true PF_UNIX SOCK_STREAM 0)
+ with Invalid_argument _ -> (p2, p2') in
+
+ let fds = [| f0;f1;f2; d0;d1;d2;
+ p0;p0';p1;p1';p2;p2';
+ s0;s1;s2;
+ x0;x0';x1;x1';x2;x2' |] in
+ let pid =
+ Unix.create_process
+ (Filename.concat Filename.current_dir_name "fdstatus.exe")
+ (Array.append [| "fdstatus" |] (Array.map string_of_fd fds))
+ Unix.stdin Unix.stdout Unix.stderr in
+ ignore (Unix.waitpid [] pid);
+ Array.iter (fun fd -> try Unix.close fd with Unix.Unix_error _ -> ()) fds;
+ Sys.remove "tmp.txt"
--- /dev/null
+#1: open
+#2: open
+#3: closed
+#4: open
+#5: open
+#6: closed
+#7: open
+#8: open
+#9: open
+#10: open
+#11: closed
+#12: closed
+#13: open
+#14: open
+#15: closed
+#16: open
+#17: open
+#18: open
+#19: open
+#20: closed
+#21: closed
--- /dev/null
+#include <stdio.h>
+
+int main (int argc, char *argv[])
+{
+ int i;
+ for (i = 1; i < argc; i ++) {
+ printf ("%s\n", argv[i]);
+ }
+ return 0;
+}
--- /dev/null
+let _ =
+ let f = Unix.dup ~cloexec:true Unix.stdout in
+ let txt = "Some output\n" in
+ ignore (Unix.write_substring f txt 0 (String.length txt));
+ Unix.close f
--- /dev/null
+Some output
--- /dev/null
+let cat file =
+ let fd = Unix.openfile file [Unix.O_RDONLY] 0 in
+ let buf = Bytes.create 1024 in
+ let rec cat () =
+ let n = Unix.read fd buf 0 (Bytes.length buf) in
+ if n > 0 then (ignore(Unix.write Unix.stdout buf 0 n); cat ())
+ in cat (); Unix.close fd
+
+let out fd txt =
+ ignore (Unix.write_substring fd txt 0 (String.length txt))
+
+let _ =
+ let fd =
+ Unix.(openfile "./tmp.txt"
+ [O_WRONLY;O_TRUNC;O_CREAT;O_SHARE_DELETE]
+ 0o600) in
+ out fd "---\n";
+ Unix.dup2 ~cloexec:true fd Unix.stderr;
+ Unix.close fd;
+ out Unix.stderr "Some output\n";
+ cat "./tmp.txt";
+ Sys.remove "./tmp.txt"
+
+
--- /dev/null
+---
+Some output
--- /dev/null
+/* Check if file descriptors are open or not */
+
+#include <stdio.h>
+#include <stdlib.h>
+
+#ifdef _WIN32
+
+#define WIN32_LEAN_AND_MEAN
+#include <wtypes.h>
+#include <winbase.h>
+#include <winerror.h>
+
+void process_fd(char * s)
+{
+ int fd;
+ HANDLE h;
+ DWORD flags;
+
+#ifdef _WIN64
+ h = (HANDLE) _atoi64(s);
+#else
+ h = (HANDLE) atoi(s);
+#endif
+ if (GetHandleInformation(h, &flags)) {
+ printf("open\n");
+ } else if (GetLastError() == ERROR_INVALID_HANDLE) {
+ printf("closed\n");
+ } else {
+ printf("error %d\n", GetLastError());
+ }
+}
+
+#else
+
+#include <limits.h>
+#include <string.h>
+#include <errno.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <unistd.h>
+
+void process_fd(char * s)
+{
+ long n;
+ int fd;
+ char * endp;
+ struct stat st;
+ n = strtol(s, &endp, 0);
+ if (*endp != 0 || n < 0 || n > (long) INT_MAX) {
+ printf("parsing error\n");
+ return;
+ }
+ fd = (int) n;
+ if (fstat(fd, &st) != -1) {
+ printf("open\n");
+ } else if (errno == EBADF) {
+ printf("closed\n");
+ } else {
+ printf("error %s\n", strerror(errno));
+ }
+}
+
+#endif
+
+int main(int argc, char ** argv)
+{
+ int i;
+ for (i = 1; i < argc; i++) {
+ printf("#%d: ", i);
+ process_fd(argv[i]);
+ }
+ return 0;
+}
--- /dev/null
+let drain pipe =
+ let max = 2048 in
+ let buf = Buffer.create 2048 in
+ let tmp = Bytes.create max in
+ while begin
+ try
+ let len = Unix.read pipe tmp 0 max in
+ Buffer.add_subbytes buf tmp 0 len;
+ len > 0
+ with Unix.Unix_error (Unix.EPIPE, _, _) when false ->
+ false
+ end do () done;
+ Buffer.contents buf
+;;
+
+let run exe args =
+ let out_in, out_out = Unix.pipe () in
+ let err_in, err_out = Unix.pipe () in
+ let args = Array.append [| exe |] args in
+ let pid = Unix.create_process exe args Unix.stdin out_out err_out in
+ Unix.close out_out;
+ Unix.close err_out;
+ let output = drain out_in in
+ let error = drain err_in in
+ Unix.close out_in;
+ Unix.close err_in;
+ let _pid, status = Unix.waitpid [ ] pid in
+ status, output, error
+;;
+
+let _ =
+ ignore (run "cp" [||]);
+ print_endline "success"
+;;
--- /dev/null
+let cat file =
+ let fd = Unix.openfile file [Unix.O_RDONLY] 0 in
+ let buf = Bytes.create 1024 in
+ let rec cat () =
+ let n = Unix.read fd buf 0 (Bytes.length buf) in
+ if n > 0 then (ignore(Unix.write Unix.stdout buf 0 n); cat ())
+ in cat (); Unix.close fd
+
+let out fd txt =
+ ignore (Unix.write_substring fd txt 0 (String.length txt))
+
+let refl =
+ Filename.concat Filename.current_dir_name "reflector.exe"
+
+let test_createprocess () =
+ let f_out =
+ Unix.(openfile "./tmpout.txt" [O_WRONLY;O_TRUNC;O_CREAT;O_CLOEXEC] 0o600) in
+ let f_err =
+ Unix.(openfile "./tmperr.txt" [O_WRONLY;O_TRUNC;O_CREAT;O_CLOEXEC] 0o600) in
+ let (p_exit, p_entrance) =
+ Unix.pipe ~cloexec:true () in
+ let pid =
+ Unix.create_process_env
+ refl
+ [| refl; "i2o"; "i2e"; "o"; "123"; "e"; "456"; "i2o"; "v"; "XVAR" |]
+ [| "XVAR=xvar" |]
+ p_exit f_out f_err in
+ out p_entrance "aaaa\n";
+ out p_entrance "bbbb\n";
+ Unix.close p_entrance;
+ let (_, status) = Unix.waitpid [] pid in
+ Unix.close p_exit; Unix.close f_out; Unix.close f_err;
+ if status <> Unix.WEXITED 0 then
+ out Unix.stdout "!!! reflector exited with an error\n";
+ out Unix.stdout "---- File tmpout.txt\n";
+ cat "./tmpout.txt";
+ out Unix.stdout "---- File tmperr.txt\n";
+ cat "./tmperr.txt";
+ Sys.remove "./tmpout.txt";
+ Sys.remove "./tmperr.txt"
+
+let test_2ampsup1 () = (* 2>&1 redirection, cf. GPR#1105 *)
+ let pid =
+ Unix.create_process
+ refl
+ [| refl; "o"; "123"; "e"; "456"; "o"; "789" |]
+ Unix.stdin Unix.stdout Unix.stdout in
+ let (_, status) = Unix.waitpid [] pid in
+ if status <> Unix.WEXITED 0 then
+ out Unix.stdout "!!! reflector exited with an error\n"
+
+let test_swap12 () = (* swapping stdout and stderr *)
+ (* The test harness doesn't let us check contents of stderr,
+ so just output on stdout (after redirection) *)
+ let pid =
+ Unix.create_process
+ refl
+ [| refl; "e"; "123" |]
+ Unix.stdin Unix.stderr Unix.stdout in
+ let (_, status) = Unix.waitpid [] pid in
+ if status <> Unix.WEXITED 0 then
+ out Unix.stdout "!!! reflector exited with an error\n"
+
+let test_open_process_in () =
+ let ic = Unix.open_process_in (refl ^ " o 123 o 456") in
+ out Unix.stdout (input_line ic ^ "\n");
+ out Unix.stdout (input_line ic ^ "\n");
+ let status = Unix.close_process_in ic in
+ if status <> Unix.WEXITED 0 then
+ out Unix.stdout "!!! reflector exited with an error\n"
+
+let test_open_process_out () =
+ let oc = Unix.open_process_out (refl ^ " i2o i2o i2o") in
+ output_string oc "aa\nbbbb\n"; close_out oc;
+ let status = Unix.close_process_out oc in
+ if status <> Unix.WEXITED 0 then
+ out Unix.stdout "!!! reflector exited with an error\n"
+
+let test_open_process_full () =
+ let ((o, i, e) as res) =
+ Unix.open_process_full
+ (refl ^ " o 123 i2o e 456 i2e v XVAR")
+ [|"XVAR=xvar"|] in
+ output_string i "aa\nbbbb\n"; close_out i;
+ for _i = 1 to 3 do
+ out Unix.stdout (input_line o ^ "\n")
+ done;
+ for _i = 1 to 2 do
+ out Unix.stdout (input_line e ^ "\n")
+ done;
+ let status = Unix.close_process_full res in
+ if status <> Unix.WEXITED 0 then
+ out Unix.stdout "!!! reflector exited with an error\n"
+
+let _ =
+ (* The following 'close' makes things more difficult.
+ Under Unix it works fine, but under Win32 create_process
+ gives an error if one of the standard handles is closed. *)
+ (* Unix.close Unix.stdin; *)
+ out Unix.stdout "** create_process\n";
+ test_createprocess();
+ out Unix.stdout "** create_process 2>&1 redirection\n";
+ test_2ampsup1();
+ out Unix.stdout "** create_process swap 1-2\n";
+ test_swap12();
+ out Unix.stdout "** open_process_in\n";
+ test_open_process_in();
+ out Unix.stdout "** open_process_out\n";
+ test_open_process_out();
+ out Unix.stdout "** open_process_full\n";
+ test_open_process_full()
+
+
--- /dev/null
+** create_process
+---- File tmpout.txt
+aaaa
+123
+<end of file>
+xvar
+---- File tmperr.txt
+bbbb
+456
+** create_process 2>&1 redirection
+123
+456
+789
+** create_process swap 1-2
+123
+** open_process_in
+123
+456
+** open_process_out
+aa
+bbbb
+<end of file>
+** open_process_full
+123
+aa
+xvar
+456
+bbbb
--- /dev/null
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+#if defined(_WIN32)
+#include <fcntl.h>
+#include <io.h>
+#endif
+
+/* A tool to read data from standard input and send it to standard
+ output or standard error. */
+
+void copyline(FILE * in, FILE * out)
+{
+ int c;
+ do {
+ c = getc(in);
+ if (c == EOF) {
+ fputs("<end of file>\n", out);
+ break;
+ }
+ putc(c, out);
+ } while (c != '\n');
+ fflush(out);
+}
+
+/* Command language:
+ i2o copy one line from stdin to stdout
+ i2e copy one line from stdin to stderr
+ o <txt> write <txt> plus newline to stdout
+ e <txt> write <txt> plus newline to stderr
+ v <var> write value of environment variable <env> to stdout
+*/
+
+int main(int argc, char ** argv)
+{
+ int i;
+ char * cmd;
+#if defined(_WIN32)
+ _setmode(_fileno(stdin), _O_BINARY);
+ _setmode(_fileno(stdout), _O_BINARY);
+ _setmode(_fileno(stderr), _O_BINARY);
+#endif
+ i = 1;
+ while (i < argc) {
+ cmd = argv[i];
+ if (strcmp(cmd, "i2o") == 0) {
+ copyline(stdin, stdout);
+ i++;
+ } else if (strcmp(cmd, "i2e") == 0) {
+ copyline(stdin, stderr);
+ i++;
+ } else if (strcmp(cmd, "o") == 0 && i + 1 < argc) {
+ fputs(argv[i + 1], stdout);
+ fputc('\n', stdout);
+ fflush(stdout);
+ i += 2;
+ } else if (strcmp(cmd, "e") == 0 && i + 1 < argc) {
+ fputs(argv[i + 1], stderr);
+ fputc('\n', stderr);
+ fflush(stderr);
+ i += 2;
+ } else if (strcmp(cmd, "v") == 0 && i + 1 < argc) {
+ char * v = getenv(argv[i + 1]);
+ fputs((v == NULL ? "<no such variable>" : v), stdout);
+ fputc('\n', stdout);
+ fflush(stdout);
+ i += 2;
+ } else {
+ fputs("<bad argument>\n", stderr);
+ return 2;
+ }
+ }
+ return 0;
+}
--- /dev/null
+open Unix
+
+let prog_name = "cmdline_prog.exe"
+
+let run args =
+ let out, inp = pipe () in
+ let in_chan = in_channel_of_descr out in
+ set_binary_mode_in in_chan false;
+ let pid = create_process ("./" ^ prog_name) (Array.of_list (prog_name :: args)) Unix.stdin inp Unix.stderr in
+ List.iter (fun arg ->
+ let s = input_line in_chan in
+ Printf.printf "%S -> %S [%s]\n" arg s (if s = arg then "OK" else "FAIL")
+ ) args;
+ close_in in_chan;
+ let _, exit = waitpid [] pid in
+ assert (exit = WEXITED 0)
+
+let () =
+ List.iter run
+ [
+ [""; ""; "\t \011"];
+ ["a"; "b"; "c.txt@!"];
+ ["\""];
+ [" "; " a "; " \" \\\" "];
+ [" \\ \\ \\\\\\"];
+ [" \"hola \""];
+ ["a\tb"];
+ ]
--- /dev/null
+"" -> "" [OK]
+"" -> "" [OK]
+"\t \011" -> "\t \011" [OK]
+"a" -> "a" [OK]
+"b" -> "b" [OK]
+"c.txt@!" -> "c.txt@!" [OK]
+"\"" -> "\"" [OK]
+" " -> " " [OK]
+" a " -> " a " [OK]
+" \" \\\" " -> " \" \\\" " [OK]
+" \\ \\ \\\\\\" -> " \\ \\ \\\\\\" [OK]
+" \"hola \"" -> " \"hola \"" [OK]
+"a\tb" -> "a\tb" [OK]
#* *
#**************************************************************************
-default: byte native
+default:
+ @$(MAKE) byte
+ @if $(BYTECODE_ONLY) ; then \
+ echo " ... testing native 'test.reference': => skipped"; \
+ else \
+ $(MAKE) native; \
+ fi
native:
@printf " ... testing native 'test.reference':"
--- /dev/null
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.expect
+include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+type t = (unit, unit, unit, unit) bar
+;;
+(* PR#7315: we expect the error location on "bar" instead of "(...) bar" *)
+[%%expect{|
+Line _, characters 34-37:
+Error: Unbound type constructor bar
+|}];;
+
+function (x :
+#bar) -> ();;
+(* we expect the location on "bar" instead of "#bar" *)
+[%%expect{|
+Line _, characters 1-4:
+Error: Unbound class bar
+|}];;
+
+function
+#bar -> ()
+;;
+(* we expect the location on "bar" instead of "#bar" *)
+[%%expect{|
+Line _, characters 1-4:
+Error: Unbound type constructor bar
+|}];;
+
+new bar;;
+(* we expect the location on "bar" instead of "new bar" *)
+[%%expect{|
+Line _, characters 4-7:
+Error: Unbound class bar
+|}];;
+
+type t =
+ | Foo of unit [@deprecated]
+ | Bar;;
+#warnings "@3";;
+let x =
+Foo ();;
+(* "Foo ()": the whole construct, with arguments, is deprecated *)
+[%%expect{|
+type t = Foo of unit | Bar
+Line _, characters 0-6:
+Warning 3: deprecated: Foo
+Line _:
+Error: Some fatal warnings were triggered (1 occurrences)
+|}];;
+function
+Foo _ -> () | Bar -> ();;
+(* "Foo _", the whole construct is deprecated *)
+[%%expect{|
+Line _, characters 0-5:
+Warning 3: deprecated: Foo
+Line _:
+Error: Some fatal warnings were triggered (1 occurrences)
+|}];;
+
+
+open Foo;;
+(* the error location should be on "Foo" *)
+[%%expect{|
+Line _, characters 5-8:
+Error: Unbound module Foo
+|}];;
+
+#warnings "@33";; (* unused open statement *)
+include (struct
+open List
+end);;
+(* here we expect the error location to be
+ on "open List" as whole rather than "List" *)
+[%%expect{|
+Line _, characters 0-9:
+Warning 33: unused open List.
+Line _:
+Error: Some fatal warnings were triggered (1 occurrences)
+|}];;
+
+type unknown += Foo;;
+(* unknown, not the whole line *)
+[%%expect{|
+Line _, characters 5-12:
+Error: Unbound type constructor unknown
+|}];;
+
+type t = ..;;
+type t +=
+Foo = Foobar;;
+(* Foobar, not the whole line *)
+[%%expect{|
+type t = ..
+Line _, characters 6-12:
+Error: Unbound constructor Foobar
+|}];;
--- /dev/null
+type t = Leaf of int | Branch of t * t
+
+let a = [| 0.0 |]
+
+let rec allocate_lots m = function
+ | 0 -> Leaf m
+ | n -> Branch (allocate_lots m (n-1), allocate_lots (m+1) (n-1))
+
+let measure f =
+ let a = Gc.minor_words () in
+ f ();
+ let c = Gc.minor_words () in
+ c -. a
+
+let () =
+ let n = measure (fun () -> a.(0) <- Gc.minor_words ()) in
+ (* Gc.minor_words should not allocate, although bytecode
+ generally boxes the floats *)
+ assert (n < 10.);
+ if Sys.backend_type = Sys.Native then assert (n = 0.);
+ let n = measure (fun () -> Sys.opaque_identity (allocate_lots 42 10)) in
+ (* This should allocate > 3k words (varying slightly by unboxing) *)
+ assert (n > 3000.);
+ print_endline "ok"
let _ = fun (x : < x : int >) y z -> (y :> 'a), (x :> 'a), (z :> 'a);;
(* - : (< x : int > as 'a) -> 'a -> 'a * 'a = <fun> *)
-(*
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 h = function M.[] | M.[a] | M.(a::q) -> () in
let i = function M.[||] | M.[|x|] -> true | _ -> false in
()
+
+class ['a] c () = object
+ constraint 'a = < .. > -> unit
+ method m = (fun x -> () : 'a)
+end
+
+let f: type a'.a' = assert false
+let foo : type a' b'. a' -> b' = fun a -> assert false
+let foo : type t' . t' = fun (type t') -> (assert false : t')
+let foo : 't . 't = fun (type t) -> (assert false : t)
+let foo : type a' b' c' t. a' -> b' -> c' -> t = fun a b c -> assert false
+
+let f x =
+ x.contents <- (print_string "coucou" ; x.contents)
+
+let ( ~$ ) x = Some x
+let g x =
+ ~$ (x.contents)
+
+let ( ~$ ) x y = (x, y)
+let g x y =
+ ~$ (x.contents) (y.contents)
(* (c) Alain Frisch / Lexifi *)
(* cf. PR#7200 *)
+
+let diff =
+ match Array.to_list Sys.argv with
+ | [_; diff] -> diff
+ | _ -> "diff -u"
+
let report_err exn =
match exn with
| Sys_error msg ->
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"
+ let cmd = Printf.sprintf "%s %s %s" diff
(Filename.quote f1) (Filename.quote f2) in
let _ret = Sys.command cmd in
print_endline"====================================================="
--- /dev/null
+#**************************************************************************
+#* *
+#* 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=../..
+
+.PHONY: default
+default:
+ @if $(BYTECODE_ONLY); then $(MAKE) skip ; else \
+ $(MAKE) compile; \
+ fi
+
+.PHONY: skip
+skip:
+ @echo " ... testing 'missing_set_of_closures' => skipped"
+
+.PHONY: compile
+compile:
+ @$(OCAMLOPT) -c a.ml
+ @$(OCAMLOPT) -c b.ml
+ @$(OCAMLOPT) -c b2.ml
+ @cp b.cmx b.cmi b2.cmx b2.cmi dir/
+ @cd dir; printf " ... testing 'missing_set_of_closures'"; \
+ $(OCAMLOPT) -w -58 -c c.ml \
+ && echo " => passed" || echo " => failed"; \
+
+.PHONY: promote
+promote:
+
+.PHONY: clean
+clean: defaultclean
+ @rm -f *.cmi *.cmx *.$(O) dir/*.cmi dir/*.cmx dir/*.$(O)
+
+include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+module type Ret = sig
+ val g : int -> int -> int
+end
+
+module F() : Ret = struct
+ let n = Sys.opaque_identity 42
+ let rec f = ((fun x -> x + n) [@inline never])
+ and g = ((fun x -> f) [@inline])
+end [@@inline never]
--- /dev/null
+
+let g =
+ let module X = A.F() in
+ X.g
--- /dev/null
+
+let f = B.g 3
--- /dev/null
+
+let f = B2.f
--- /dev/null
+#**************************************************************************
+#* *
+#* 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. *
+#* *
+#**************************************************************************
+
+MAIN_MODULE=pr7426
+
+BASEDIR=../../..
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+class some_class = object val some_val = 0.0 end
--- /dev/null
+BASEDIR=../..
+#MODULES=
+MAIN_MODULE=test
+C_FILES=stub_test
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+#include <string.h>
+#include "caml/memory.h"
+#include "caml/alloc.h"
+#include "caml/mlvalues.h"
+#include "caml/fail.h"
+
+char *some_dynamic_string_that_should_be_freed()
+{
+ return strdup("bar");
+}
+
+CAMLexport value dynamic_invalid_argument(value unit)
+{
+ CAMLparam1(unit);
+ char *dynamic_msg = some_dynamic_string_that_should_be_freed();
+ value msg = caml_copy_string(dynamic_msg);
+ free(dynamic_msg);
+ caml_invalid_argument_value(msg);
+ CAMLnoreturn;
+}
--- /dev/null
+external failwith_from_ocaml : string -> 'a = "caml_failwith_value"
+
+external dynamic_invalid_argument : unit -> 'a = "dynamic_invalid_argument"
+
+let () =
+ try failwith_from_ocaml ("fo" ^ "o")
+ with Failure foo -> print_endline foo
+
+let () =
+ try dynamic_invalid_argument ()
+ with Invalid_argument bar -> print_endline bar
--- /dev/null
+#**************************************************************************
+#* *
+#* OCaml *
+#* *
+#* Bernhard Schommer *
+#* *
+#* 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=../..
+
+
+default:
+ @$(MAKE) byte
+ @if $(BYTECODE_ONLY); then $(MAKE) opt-skipped ; else \
+ $(MAKE) opt; \
+ fi
+
+byte:
+ @$(OCAMLC) unknown-file 2>&1 | grep "don't know what to do with unknown-file" \
+ > unknown-file.byte.result || true
+ @for file in *.byte.reference; do \
+ printf " ... testing '$$file':"; \
+ $(DIFF) $$file `basename $$file reference`result >/dev/null \
+ && echo " => passed" || echo " => failed"; \
+ done
+
+opt:
+ @$(OCAMLOPT) unknown-file 2>&1 | grep "don't know what to do with unknown-file"\
+ > unknown-file.opt.result || true
+ @for file in *.opt.reference; do \
+ printf " ... testing '$$file':"; \
+ $(DIFF) $$file `basename $$file reference`result >/dev/null \
+ && echo " => passed" || echo " => failed"; \
+ done
+
+opt-skipped:
+ @for file in *.opt.reference; do \
+ printf " ... testing '$$file':"; \
+ echo " => skipped"; \
+ done
+
+promote: defaultpromote
+
+clean: defaultclean
+ @rm -f *.result
+
+include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+don't know what to do with unknown-file
--- /dev/null
+don't know what to do with unknown-file
program.byte$(EXE) >$(MAIN_MODULE).raw.result 2>&1 \
&& sed -e '/Debugger version/d' -e '/^Time:/d' \
-e '/Breakpoint [0-9]* at [0-9]*:/d' -e '$$d' \
- $(MAIN_MODULE).raw.result >$(MAIN_MODULE).result \
+ $(MAIN_MODULE).raw.result | tr -d '\r' >$(MAIN_MODULE).result \
&& $(DIFF) $(MAIN_MODULE).reference $(MAIN_MODULE).result >/dev/null \
&& echo " => passed" || echo " => failed"
--- /dev/null
+BASEDIR=../..
+
+compile:
+ @printf " ... testing 'foo.ml'"
+ @$(OCAMLC) -c a.ml
+ @$(OCAMLC) -open A.M -c b.ml \
+ && echo " => passed" || echo " => failed"
+
+promote:
+
+clean:
+ @rm -f a.cmi a.cmo b.cmi b.cmo
+
+include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+module M = struct
+ let f x = x +1
+end
fi
.PHONY: run
-run: *.ml *.mli
- @for file in *.mli *.ml; do \
+run: *.ml *.mli *.txt
+ @for file in *.mli *.ml *.txt; do \
printf " ... testing '$$file'"; \
F="`basename $$file .mli`"; \
F="`basename $$F .ml`"; \
+ F="`basename $$F .txt`"; \
$(OCAMLDOC) $(DOCFLAGS) -hide-warnings -latex $ \
-o $$F.result $$file; \
$(DIFF) $$F.reference $$F.result >/dev/null \
\begin{ocamldoccode}
exception Less of int
-
\end{ocamldoccode}
\index{Less@\verb`Less`}
\begin{ocamldocdescription}
\end{ocamldoccomment}
\begin{ocamldoccode}
{\char125}
-
\end{ocamldoccode}
\index{Error@\verb`Error`}
\end{ocamldoccomment}
\begin{ocamldoccode}
{\char125}
-
\end{ocamldoccode}
\begin{ocamldoccomment}
Constructor E documentation
\end{ocamldoccomment}
\begin{ocamldoccode}
{\char125}
-
\end{ocamldoccode}
\begin{ocamldoccomment}
Constructor F documentation
\end{ocamldoccomment}
\begin{ocamldoccode}
{\char125}
-
\end{ocamldoccode}
\begin{ocamldoccomment}
Constructor G documentation
\begin{ocamldoccode}
exception Less of int
-
\end{ocamldoccode}
\index{Less@\verb`Less`}
\begin{ocamldocdescription}
\end{ocamldoccomment}
\begin{ocamldoccode}
{\char125}
-
\end{ocamldoccode}
\index{Error@\verb`Error`}
\end{ocamldoccomment}
\begin{ocamldoccode}
{\char125}
-
\end{ocamldoccode}
\begin{ocamldoccomment}
Constructor E documentation
\end{ocamldoccomment}
\begin{ocamldoccode}
{\char125}
-
\end{ocamldoccode}
\begin{ocamldoccomment}
Constructor F documentation
\end{ocamldoccomment}
\begin{ocamldoccode}
{\char125}
-
\end{ocamldoccode}
\begin{ocamldoccomment}
Constructor G documentation
--- /dev/null
+
+module rec A : sig type t end = B and B : sig type t = A.t end = A;;
+
--- /dev/null
+\documentclass[11pt]{article}
+\usepackage[latin1]{inputenc}
+\usepackage[T1]{fontenc}
+\usepackage{textcomp}
+\usepackage{fullpage}
+\usepackage{url}
+\usepackage{ocamldoc}
+\begin{document}
+\tableofcontents
+\section{Module {\tt{Loop}}}
+\label{Loop}\index{Loop@\verb`Loop`}
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\begin{ocamldoccode}
+{\tt{module }}{\tt{A}}{\tt{ : }}\end{ocamldoccode}
+\label{Loop.A}\index{A@\verb`A`}
+
+{\tt{B}}
+
+
+
+
+
+\begin{ocamldoccode}
+{\tt{module }}{\tt{B}}{\tt{ : }}\end{ocamldoccode}
+\label{Loop.B}\index{B@\verb`B`}
+
+{\tt{A}}
+
+
+
+\end{document}
\ No newline at end of file
--- /dev/null
+\documentclass[11pt]{article}
+\usepackage[latin1]{inputenc}
+\usepackage[T1]{fontenc}
+\usepackage{textcomp}
+\usepackage{fullpage}
+\usepackage{url}
+\usepackage{ocamldoc}
+\begin{document}
+\tableofcontents
+\section{Short\_description : Short global description in text mode}
+\label{Short-underscoredescription}\index{Short-underscoredescription@\verb`Short_description`}
+
+
+
+This file tests that documentation in text mode are given
+a short description in the global description of modules.
+
+
+
+
+\end{document}
\ No newline at end of file
--- /dev/null
+Short global description in text mode
+
+This file tests that documentation in text mode are given
+a short description in the global description of modules.
--- /dev/null
+(** This test is here to check the latex code generated for variants *)
+
+type s = A | B (** only B is documented here *) | C
+
+type t =
+ | A
+ (** doc for A *)
+ | B
+ (** doc for B *)
+
+(** Some documentation for u*)
+type u =
+| A (** doc for A *) | B of unit (** doc for B *)
+
+
+(** With records *)
+type w =
+| A of { x: int }
+ (** doc for A *)
+| B of { y:int }
+ (** doc for B *)
+
+(** With args *)
+type z =
+| A of int
+ (** doc for A *)
+| B of int
+ (** doc for B *)
+
+(** Gadt notation *)
+type a =
+ A: a (** doc for A*)
+
+(** Lonely constructor *)
+type b =
+ B (** doc for B *)
+
+type no_documentation = A | B | C
--- /dev/null
+\documentclass[11pt]{article}
+\usepackage[latin1]{inputenc}
+\usepackage[T1]{fontenc}
+\usepackage{textcomp}
+\usepackage{fullpage}
+\usepackage{url}
+\usepackage{ocamldoc}
+\begin{document}
+\tableofcontents
+\section{Module {\tt{Variants}} : This test is here to check the latex code generated for variants}
+\label{Variants}\index{Variants@\verb`Variants`}
+
+
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\label{TYPVariants.s}\begin{ocamldoccode}
+type s =
+ | A
+ | B
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+only B is documented here
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+ | C
+\end{ocamldoccode}
+\index{s@\verb`s`}
+
+
+
+
+\label{TYPVariants.t}\begin{ocamldoccode}
+type t =
+ | A
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+doc for A
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+ | B
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+doc for B
+
+
+\end{ocamldoccomment}
+\index{t@\verb`t`}
+
+
+
+
+\label{TYPVariants.u}\begin{ocamldoccode}
+type u =
+ | A
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+doc for A
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+ | B of unit
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+doc for B
+
+
+\end{ocamldoccomment}
+\index{u@\verb`u`}
+\begin{ocamldocdescription}
+Some documentation for u
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPVariants.w}\begin{ocamldoccode}
+type w =
+ | A of {\char123} x : int ;
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+doc for A
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+ | B of {\char123} y : int ;
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+doc for B
+
+
+\end{ocamldoccomment}
+\index{w@\verb`w`}
+\begin{ocamldocdescription}
+With records
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPVariants.z}\begin{ocamldoccode}
+type z =
+ | A of int
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+doc for A
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+ | B of int
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+doc for B
+
+
+\end{ocamldoccomment}
+\index{z@\verb`z`}
+\begin{ocamldocdescription}
+With args
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPVariants.a}\begin{ocamldoccode}
+type a =
+ | A : a
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+doc for A
+
+
+\end{ocamldoccomment}
+\index{a@\verb`a`}
+\begin{ocamldocdescription}
+Gadt notation
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPVariants.b}\begin{ocamldoccode}
+type b =
+ | B
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+doc for B
+
+
+\end{ocamldoccomment}
+\index{b@\verb`b`}
+\begin{ocamldocdescription}
+Lonely constructor
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPVariants.no-underscoredocumentation}\begin{ocamldoccode}
+type no_documentation =
+ | A
+ | B
+ | C
+\end{ocamldoccode}
+\index{no-underscoredocumentation@\verb`no_documentation`}
+
+
+\end{document}
\ No newline at end of file
--- /dev/null
+
+module rec A : sig type t end = B and B : sig type t = A.t end = A;;
+
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<html>
+<head>
+<link rel="stylesheet" href="style.css" type="text/css">
+<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
+<meta name="viewport" content="width=device-width, initial-scale=1">
+<link rel="Start" href="index.html">
+<link rel="Up" href="index.html">
+<link title="Index of modules" rel=Appendix href="index_modules.html">
+<link title="Loop" rel="Chapter" href="Loop.html"><title>Loop</title>
+</head>
+<body>
+<div class="navbar"> <a class="up" href="index.html" title="Index">Up</a>
+ </div>
+<h1>Module <a href="type_Loop.html">Loop</a></h1>
+
+<pre><span class="keyword">module</span> Loop: <code class="code"><span class="keyword">sig</span></code> <a href="Loop.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><hr width="100%">
+
+<pre><span class="keyword">module</span> <a href="Loop.A.html">A</a>: <code class="type"><a href="Loop.B.html">B</a></code></pre>
+<pre><span class="keyword">module</span> <a href="Loop.B.html">B</a>: <code class="type"><a href="Loop.A.html">A</a></code></pre></body></html>
\ No newline at end of file
fi
.PHONY: run
-run: *.mli
- @for file in *.mli; do \
+run: *.mli *.ml
+# Note that we strip both .ml and .mli extensions
+ @for file in *.ml *.mli; do \
printf " ... testing '$$file'"; \
F="`basename $$file .mli`"; \
+ F="`basename $$F .ml`"; \
$(OCAMLDOC) $(DOCFLAGS) -colorize-code -hide-warnings -html $ \
-o index $$file; \
cp $$F.html $$F.result; \
&& echo " => passed" || echo " => failed"; \
done;\
# For linebreaks.mli, we also compare type_Linebreaks.html and not only
-# themain html file
+# the main html file
@cp type_Linebreaks.html type_Linebreaks.result;\
printf " ... testing 'type_Linebreak.html'";\
$(DIFF) type_Linebreaks.reference type_Linebreaks.result\
--- /dev/null
+module M = Set.Make(struct
+ type t = int
+ let compare = compare
+end)
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<html>
+<head>
+<link rel="stylesheet" href="style.css" type="text/css">
+<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
+<meta name="viewport" content="width=device-width, initial-scale=1">
+<link rel="Start" href="index.html">
+<link rel="Up" href="index.html">
+<link title="Index of modules" rel=Appendix href="index_modules.html">
+<link title="Module_whitespace" rel="Chapter" href="Module_whitespace.html"><title>Module_whitespace</title>
+</head>
+<body>
+<div class="navbar"> <a class="up" href="index.html" title="Index">Up</a>
+ </div>
+<h1>Module <a href="type_Module_whitespace.html">Module_whitespace</a></h1>
+
+<pre><span class="keyword">module</span> Module_whitespace: <code class="code"><span class="keyword">sig</span></code> <a href="Module_whitespace.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><hr width="100%">
+
+<pre><span class="keyword">module</span> <a href="Module_whitespace.M.html">M</a>: <code class="type">Set.Make</code><code class="code">(</code><code class="code"><span class="keyword">sig</span></code></pre><div class="sig_block">
+<pre><span id="TYPEt"><span class="keyword">type</span> <code class="type"></code>t</span> = <code class="type">int</code> </pre>
+
+
+<pre><span id="VALcompare"><span class="keyword">val</span> compare</span> : <code class="type">'a -> 'a -> int</code></pre></div>
+<pre><code class="code"><span class="keyword">end</span></code><code class="code">)</code></pre></body></html>
\ No newline at end of file
--- /dev/null
+(** This test is here to check the latex code generated for variants *)
+
+type s = A | B (** only B is documented here *) | C
+
+type t =
+ | A
+ (** doc for A *)
+ | B
+ (** doc for B *)
+
+(** Some documentation for u*)
+type u =
+| A (** doc for A *) | B of unit (** doc for B *)
+
+
+(** With records *)
+type w =
+| A of { x: int }
+ (** doc for A *)
+| B of { y:int }
+ (** doc for B *)
+
+(** With args *)
+type z =
+| A of int
+ (** doc for A *)
+| B of int
+ (** doc for B *)
+
+(** Gadt notation *)
+type a =
+ A: a (** doc for A*)
+
+(** Lonely constructor *)
+type b =
+ B (** doc for B *)
+
+type no_documentation = A | B | C
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<html>
+<head>
+<link rel="stylesheet" href="style.css" type="text/css">
+<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
+<meta name="viewport" content="width=device-width, initial-scale=1">
+<link rel="Start" href="index.html">
+<link rel="Up" href="index.html">
+<link title="Index of types" rel=Appendix href="index_types.html">
+<link title="Index of modules" rel=Appendix href="index_modules.html">
+<link title="Variants" rel="Chapter" href="Variants.html"><title>Variants</title>
+</head>
+<body>
+<div class="navbar"> <a class="up" href="index.html" title="Index">Up</a>
+ </div>
+<h1>Module <a href="type_Variants.html">Variants</a></h1>
+
+<pre><span class="keyword">module</span> Variants: <code class="code"><span class="keyword">sig</span></code> <a href="Variants.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><div class="info module top">
+This test is here to check the latex code generated for variants<br>
+</div>
+<hr width="100%">
+
+<pre><code><span id="TYPEs"><span class="keyword">type</span> <code class="type"></code>s</span> = </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTs.A"><span class="constructor">A</span></span></code></td>
+
+</tr>
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTs.B"><span class="constructor">B</span></span></code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+only B is documented here<br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr>
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTs.C"><span class="constructor">C</span></span></code></td>
+
+</tr></table>
+
+
+
+<pre><code><span id="TYPEt"><span class="keyword">type</span> <code class="type"></code>t</span> = </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTt.A"><span class="constructor">A</span></span></code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+doc for A<br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr>
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTt.B"><span class="constructor">B</span></span></code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+doc for B<br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+
+
+
+<pre><code><span id="TYPEu"><span class="keyword">type</span> <code class="type"></code>u</span> = </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTu.A"><span class="constructor">A</span></span></code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+doc for A<br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr>
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTu.B"><span class="constructor">B</span></span> <span class="keyword">of</span> <code class="type">unit</code></code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+doc for B<br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+
+<div class="info ">
+Some documentation for u<br>
+</div>
+
+
+<pre><code><span id="TYPEw"><span class="keyword">type</span> <code class="type"></code>w</span> = </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTw.A"><span class="constructor">A</span></span> <span class="keyword">of</span> <code>{</code><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code> </code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTVariants.A.x">x</span> : <code class="type">int</code>;</code></td>
+
+</tr></table>
+}
+</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+doc for A<br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr>
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTw.B"><span class="constructor">B</span></span> <span class="keyword">of</span> <code>{</code><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code> </code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTVariants.B.y">y</span> : <code class="type">int</code>;</code></td>
+
+</tr></table>
+}
+</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+doc for B<br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+
+<div class="info ">
+With records<br>
+</div>
+
+
+<pre><code><span id="TYPEz"><span class="keyword">type</span> <code class="type"></code>z</span> = </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTz.A"><span class="constructor">A</span></span> <span class="keyword">of</span> <code class="type">int</code></code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+doc for A<br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr>
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTz.B"><span class="constructor">B</span></span> <span class="keyword">of</span> <code class="type">int</code></code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+doc for B<br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+
+<div class="info ">
+With args<br>
+</div>
+
+
+<pre><code><span id="TYPEa"><span class="keyword">type</span> <code class="type"></code>a</span> = </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTa.A"><span class="constructor">A</span></span> <span class="keyword">:</span> <code class="type"><a href="Variants.html#TYPEa">a</a></code></code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+doc for A<br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+
+<div class="info ">
+Gadt notation<br>
+</div>
+
+
+<pre><code><span id="TYPEb"><span class="keyword">type</span> <code class="type"></code>b</span> = </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTb.B"><span class="constructor">B</span></span></code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+doc for B<br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+
+<div class="info ">
+Lonely constructor<br>
+</div>
+
+
+<pre><code><span id="TYPEno_documentation"><span class="keyword">type</span> <code class="type"></code>no_documentation</span> = </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTno_documentation.A"><span class="constructor">A</span></span></code></td>
+
+</tr>
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTno_documentation.B"><span class="constructor">B</span></span></code></td>
+
+</tr>
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTno_documentation.C"><span class="constructor">C</span></span></code></td>
+
+</tr></table>
+
+
+</body></html>
\ No newline at end of file
main.odoc: alias.cmi main.ml
@$(OCAMLDOC) $(DOCFLAGS) -hide-warnings \
- -open Alias -open Aliased_inner -dump main.odoc main.ml
+ -open Alias.Container -open Aliased_inner -dump main.odoc main.ml
alias.cmi:inner.cmi
-module Aliased_inner = Inner
+module Container = struct
+ module Aliased_inner = Inner
+end
\begin{ocamldoccode}
-{\tt{module }}{\tt{Aliased\_inner}}{\tt{ : }}\end{ocamldoccode}
-\label{module:Alias.Aliased-underscoreinner}\index{Aliased-underscoreinner@\verb`Aliased_inner`}
+{\tt{module }}{\tt{Container}}{\tt{ : }}\end{ocamldoccode}
+\label{module:Alias.Container}\index{Container@\verb`Container`}
+
+\begin{ocamldocsigend}
+
+\begin{ocamldoccode}
+{\tt{module }}{\tt{Aliased\_inner}}{\tt{ : }}\end{ocamldoccode}
+\label{module:Alias.Container.Aliased-underscoreinner}\index{Aliased-underscoreinner@\verb`Aliased_inner`}
{\tt{Inner}}
+\end{ocamldocsigend}
+
+
\section{Module {\tt{Inner}}}
\label{type:Main.t}\begin{ocamldoccode}
-type t = Alias.Aliased_inner.a
+type t = Alias.Container.Aliased_inner.a
\end{ocamldoccode}
\index{t@\verb`t`}
\begin{ocamldocdescription}
--- /dev/null
+
+module rec A : sig type t end = B and B : sig type t = A.t end = A;;
+
--- /dev/null
+#
+# module T05:
+#
+# module T05.A:
+#
+# module T05.B:
--- /dev/null
+#**************************************************************************
+#* *
+#* OCaml *
+#* *
+#* Bernhard Schommer *
+#* *
+#* 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=../..
+
+
+default:
+ @for file in *.txt; do \
+ TERM=dumb $(OCAML) -args $$file < test.ml 2>&1 \
+ | grep -v '^ OCaml version' > $$file.result; \
+ done
+ @for file in *.reference; do \
+ printf " ... testing '$$file':"; \
+ $(DIFF) $$file `basename $$file reference`result >/dev/null \
+ && echo " => passed" || echo " => failed"; \
+ done
+
+
+promote: defaultpromote
+
+clean: defaultclean
+ @rm -f *.result
+
+include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+test.ml
+-I
+../
--- /dev/null
+For implementation reasons, the toplevel does not support having script files (here "test.ml") inside expanded arguments passed through the -args{,0} command-line option.
--- /dev/null
+-args
+first_arg_fail.txt
--- /dev/null
+For implementation reasons, the toplevel does not support having script files (here "test.ml") inside expanded arguments passed through the -args{,0} command-line option.
--- /dev/null
+-args
+last_arg_fail.txt
--- /dev/null
+For implementation reasons, the toplevel does not support having script files (here "test.ml") inside expanded arguments passed through the -args{,0} command-line option.
--- /dev/null
+-I
+../
+test.ml
--- /dev/null
+For implementation reasons, the toplevel does not support having script files (here "test.ml") inside expanded arguments passed through the -args{,0} command-line option.
--- /dev/null
+printf "Test succeeds\n";;
--- /dev/null
+-open
+Printf
--- /dev/null
+
+# Test succeeds
+- : unit = ()
+#
BASEDIR=../..
include $(BASEDIR)/makefiles/Makefile.toplevel
include $(BASEDIR)/makefiles/Makefile.common
+TOPFLAGS+=-I $(OTOPDIR)/toplevel
--- /dev/null
+type t = A | B;;
+type u = C of t;;
+let print_t out = function A -> Format.fprintf out "A";;
+#install_printer print_t;;
+B;;
+C B;;
--- /dev/null
+
+# type t = A | B
+# type u = C of t
+# Characters 18-54:
+ let print_t out = function A -> Format.fprintf out "A";;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+B
+val print_t : Format.formatter -> t -> unit = <fun>
+# # - : t =
+<printer print_t raised an exception: File "//toplevel//", line 1, characters 18-23: Pattern matching failed>
+# - : u =
+C
+ <printer print_t raised an exception: File "//toplevel//", line 1, characters 18-23: Pattern matching failed>
+#
(function a x (array.unsafe_set[gen] a 0 x))
(let
(eta_gen_len =
- (function prim (array.length[gen] prim))
+ (function prim stub (array.length[gen] prim))
eta_gen_safe_get =
- (function prim prim
+ (function prim prim stub
(array.get[gen] prim prim))
eta_gen_unsafe_get =
- (function prim prim
+ (function prim prim stub
(array.unsafe_get[gen] prim prim))
eta_gen_safe_set =
- (function prim prim prim
+ (function prim prim prim stub
(array.set[gen] prim prim prim))
eta_gen_unsafe_set =
- (function prim prim prim
+ (function prim prim prim stub
(array.unsafe_set[gen] prim prim prim))
eta_int_len =
- (function prim (array.length[int] prim))
+ (function prim stub (array.length[int] prim))
eta_int_safe_get =
- (function prim prim
+ (function prim prim stub
(array.get[int] prim prim))
eta_int_unsafe_get =
- (function prim prim
+ (function prim prim stub
(array.unsafe_get[int] prim prim))
eta_int_safe_set =
- (function prim prim prim
+ (function prim prim prim stub
(array.set[int] prim prim prim))
eta_int_unsafe_set =
- (function prim prim prim
+ (function prim prim prim stub
(array.unsafe_set[int] prim prim prim))
eta_float_len =
- (function prim (array.length[float] prim))
+ (function prim stub (array.length[float] prim))
eta_float_safe_get =
- (function prim prim
+ (function prim prim stub
(array.get[float] prim prim))
eta_float_unsafe_get =
- (function prim prim
+ (function prim prim stub
(array.unsafe_get[float] prim prim))
eta_float_safe_set =
- (function prim prim prim
+ (function prim prim prim stub
(array.set[float] prim prim prim))
eta_float_unsafe_set =
- (function prim prim prim
+ (function prim prim prim stub
(array.unsafe_set[float] prim prim prim))
eta_addr_len =
- (function prim (array.length[addr] prim))
+ (function prim stub (array.length[addr] prim))
eta_addr_safe_get =
- (function prim prim
+ (function prim prim stub
(array.get[addr] prim prim))
eta_addr_unsafe_get =
- (function prim prim
+ (function prim prim stub
(array.unsafe_get[addr] prim prim))
eta_addr_safe_set =
- (function prim prim prim
+ (function prim prim prim stub
(array.set[addr] prim prim prim))
eta_addr_unsafe_set =
- (function prim prim prim
+ (function prim prim prim stub
(array.unsafe_set[addr] prim prim prim)))
(makeblock 0 int_a float_a addr_a eta_gen_len
eta_gen_safe_get eta_gen_unsafe_get eta_gen_safe_set
nativeint_ge =
(function x y (Nativeint.>= x y))
eta_gen_cmp =
- (function prim prim (caml_compare prim prim))
+ (function prim prim stub (caml_compare prim prim))
eta_int_cmp =
- (function prim prim (caml_int_compare prim prim))
+ (function prim prim stub
+ (caml_int_compare prim prim))
eta_bool_cmp =
- (function prim prim (caml_int_compare prim prim))
+ (function prim prim stub
+ (caml_int_compare prim prim))
eta_intlike_cmp =
- (function prim prim (caml_int_compare prim prim))
+ (function prim prim stub
+ (caml_int_compare prim prim))
eta_float_cmp =
- (function prim prim
+ (function prim prim stub
(caml_float_compare prim prim))
eta_string_cmp =
- (function prim prim
+ (function prim prim stub
(caml_string_compare prim prim))
eta_int32_cmp =
- (function prim prim
+ (function prim prim stub
(caml_int32_compare prim prim))
eta_int64_cmp =
- (function prim prim
+ (function prim prim stub
(caml_int64_compare prim prim))
eta_nativeint_cmp =
- (function prim prim
+ (function prim prim stub
(caml_nativeint_compare prim prim))
eta_gen_eq =
- (function prim prim (caml_equal prim prim))
+ (function prim prim stub (caml_equal prim prim))
eta_int_eq =
- (function prim prim (== prim prim))
+ (function prim prim stub (== prim prim))
eta_bool_eq =
- (function prim prim (== prim prim))
+ (function prim prim stub (== prim prim))
eta_intlike_eq =
- (function prim prim (== prim prim))
+ (function prim prim stub (== prim prim))
eta_float_eq =
- (function prim prim (==. prim prim))
+ (function prim prim stub (==. prim prim))
eta_string_eq =
- (function prim prim (caml_string_equal prim prim))
+ (function prim prim stub
+ (caml_string_equal prim prim))
eta_int32_eq =
- (function prim prim (Int32.== prim prim))
+ (function prim prim stub (Int32.== prim prim))
eta_int64_eq =
- (function prim prim (Int64.== prim prim))
+ (function prim prim stub (Int64.== prim prim))
eta_nativeint_eq =
- (function prim prim (Nativeint.== prim prim))
+ (function prim prim stub (Nativeint.== prim prim))
eta_gen_ne =
- (function prim prim (caml_notequal prim prim))
+ (function prim prim stub
+ (caml_notequal prim prim))
eta_int_ne =
- (function prim prim (!= prim prim))
+ (function prim prim stub (!= prim prim))
eta_bool_ne =
- (function prim prim (!= prim prim))
+ (function prim prim stub (!= prim prim))
eta_intlike_ne =
- (function prim prim (!= prim prim))
+ (function prim prim stub (!= prim prim))
eta_float_ne =
- (function prim prim (!=. prim prim))
+ (function prim prim stub (!=. prim prim))
eta_string_ne =
- (function prim prim
+ (function prim prim stub
(caml_string_notequal prim prim))
eta_int32_ne =
- (function prim prim (Int32.!= prim prim))
+ (function prim prim stub (Int32.!= prim prim))
eta_int64_ne =
- (function prim prim (Int64.!= prim prim))
+ (function prim prim stub (Int64.!= prim prim))
eta_nativeint_ne =
- (function prim prim (Nativeint.!= prim prim))
+ (function prim prim stub (Nativeint.!= prim prim))
eta_gen_lt =
- (function prim prim (caml_lessthan prim prim))
- eta_int_lt = (function prim prim (< prim prim))
+ (function prim prim stub
+ (caml_lessthan prim prim))
+ eta_int_lt =
+ (function prim prim stub (< prim prim))
eta_bool_lt =
- (function prim prim (< prim prim))
+ (function prim prim stub (< prim prim))
eta_intlike_lt =
- (function prim prim (< prim prim))
+ (function prim prim stub (< prim prim))
eta_float_lt =
- (function prim prim (<. prim prim))
+ (function prim prim stub (<. prim prim))
eta_string_lt =
- (function prim prim
+ (function prim prim stub
(caml_string_lessthan prim prim))
eta_int32_lt =
- (function prim prim (Int32.< prim prim))
+ (function prim prim stub (Int32.< prim prim))
eta_int64_lt =
- (function prim prim (Int64.< prim prim))
+ (function prim prim stub (Int64.< prim prim))
eta_nativeint_lt =
- (function prim prim (Nativeint.< prim prim))
+ (function prim prim stub (Nativeint.< prim prim))
eta_gen_gt =
- (function prim prim (caml_greaterthan prim prim))
- eta_int_gt = (function prim prim (> prim prim))
+ (function prim prim stub
+ (caml_greaterthan prim prim))
+ eta_int_gt =
+ (function prim prim stub (> prim prim))
eta_bool_gt =
- (function prim prim (> prim prim))
+ (function prim prim stub (> prim prim))
eta_intlike_gt =
- (function prim prim (> prim prim))
+ (function prim prim stub (> prim prim))
eta_float_gt =
- (function prim prim (>. prim prim))
+ (function prim prim stub (>. prim prim))
eta_string_gt =
- (function prim prim
+ (function prim prim stub
(caml_string_greaterthan prim prim))
eta_int32_gt =
- (function prim prim (Int32.> prim prim))
+ (function prim prim stub (Int32.> prim prim))
eta_int64_gt =
- (function prim prim (Int64.> prim prim))
+ (function prim prim stub (Int64.> prim prim))
eta_nativeint_gt =
- (function prim prim (Nativeint.> prim prim))
+ (function prim prim stub (Nativeint.> prim prim))
eta_gen_le =
- (function prim prim (caml_lessequal prim prim))
+ (function prim prim stub
+ (caml_lessequal prim prim))
eta_int_le =
- (function prim prim (<= prim prim))
+ (function prim prim stub (<= prim prim))
eta_bool_le =
- (function prim prim (<= prim prim))
+ (function prim prim stub (<= prim prim))
eta_intlike_le =
- (function prim prim (<= prim prim))
+ (function prim prim stub (<= prim prim))
eta_float_le =
- (function prim prim (<=. prim prim))
+ (function prim prim stub (<=. prim prim))
eta_string_le =
- (function prim prim
+ (function prim prim stub
(caml_string_lessequal prim prim))
eta_int32_le =
- (function prim prim (Int32.<= prim prim))
+ (function prim prim stub (Int32.<= prim prim))
eta_int64_le =
- (function prim prim (Int64.<= prim prim))
+ (function prim prim stub (Int64.<= prim prim))
eta_nativeint_le =
- (function prim prim (Nativeint.<= prim prim))
+ (function prim prim stub (Nativeint.<= prim prim))
eta_gen_ge =
- (function prim prim (caml_greaterequal prim prim))
+ (function prim prim stub
+ (caml_greaterequal prim prim))
eta_int_ge =
- (function prim prim (>= prim prim))
+ (function prim prim stub (>= prim prim))
eta_bool_ge =
- (function prim prim (>= prim prim))
+ (function prim prim stub (>= prim prim))
eta_intlike_ge =
- (function prim prim (>= prim prim))
+ (function prim prim stub (>= prim prim))
eta_float_ge =
- (function prim prim (>=. prim prim))
+ (function prim prim stub (>=. prim prim))
eta_string_ge =
- (function prim prim
+ (function prim prim stub
(caml_string_greaterequal prim prim))
eta_int32_ge =
- (function prim prim (Int32.>= prim prim))
+ (function prim prim stub (Int32.>= prim prim))
eta_int64_ge =
- (function prim prim (Int64.>= prim prim))
+ (function prim prim stub (Int64.>= prim prim))
eta_nativeint_ge =
- (function prim prim (Nativeint.>= prim prim))
+ (function prim prim stub (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]]]
(apply f (field 0 param) (field 1 param)))
map =
(function f l
- (apply (field 12 (global List!)) (apply uncurry f)
+ (apply (field 15 (global List!)) (apply uncurry f)
l)))
(makeblock 0
(makeblock 0 (apply map gen_cmp vec)
(apply f (field 0 param) (field 1 param)))
map =
(function f l
- (apply (field 12 (global List!))
+ (apply (field 15 (global List!))
(apply uncurry f) l)))
(makeblock 0
(makeblock 0 (apply map eta_gen_cmp vec)
(setglobal Module_coercion!
(let (M = (makeblock 0))
(makeblock 0 M
- (makeblock 0 (function prim (array.length[int] prim))
- (function prim prim (array.get[int] prim prim))
- (function prim prim
+ (makeblock 0 (function prim stub (array.length[int] prim))
+ (function prim prim stub
+ (array.get[int] prim prim))
+ (function prim prim stub
(array.unsafe_get[int] prim prim))
- (function prim prim prim
+ (function prim prim prim stub
(array.set[int] prim prim prim))
- (function prim prim prim
+ (function prim prim prim stub
(array.unsafe_set[int] prim prim prim))
- (function prim prim (caml_int_compare prim prim))
- (function prim prim (== prim prim))
- (function prim prim (!= prim prim))
- (function prim prim (< prim prim))
- (function prim prim (> prim prim))
- (function prim prim (<= prim prim))
- (function prim prim (>= prim prim)))
- (makeblock 0 (function prim (array.length[float] prim))
- (function prim prim (array.get[float] prim prim))
- (function prim prim
+ (function prim prim stub
+ (caml_int_compare prim prim))
+ (function prim prim stub (== prim prim))
+ (function prim prim stub (!= prim prim))
+ (function prim prim stub (< prim prim))
+ (function prim prim stub (> prim prim))
+ (function prim prim stub (<= prim prim))
+ (function prim prim stub (>= prim prim)))
+ (makeblock 0 (function prim stub (array.length[float] prim))
+ (function prim prim stub
+ (array.get[float] prim prim))
+ (function prim prim stub
(array.unsafe_get[float] prim prim))
- (function prim prim prim
+ (function prim prim prim stub
(array.set[float] prim prim prim))
- (function prim prim prim
+ (function prim prim prim stub
(array.unsafe_set[float] prim prim prim))
- (function prim prim
+ (function prim prim stub
(caml_float_compare prim prim))
- (function prim prim (==. prim prim))
- (function prim prim (!=. prim prim))
- (function prim prim (<. prim prim))
- (function prim prim (>. prim prim))
- (function prim prim (<=. prim prim))
- (function prim prim (>=. prim prim)))
- (makeblock 0 (function prim (array.length[addr] prim))
- (function prim prim (array.get[addr] prim prim))
- (function prim prim
+ (function prim prim stub (==. prim prim))
+ (function prim prim stub (!=. prim prim))
+ (function prim prim stub (<. prim prim))
+ (function prim prim stub (>. prim prim))
+ (function prim prim stub (<=. prim prim))
+ (function prim prim stub (>=. prim prim)))
+ (makeblock 0 (function prim stub (array.length[addr] prim))
+ (function prim prim stub
+ (array.get[addr] prim prim))
+ (function prim prim stub
(array.unsafe_get[addr] prim prim))
- (function prim prim prim
+ (function prim prim prim stub
(array.set[addr] prim prim prim))
- (function prim prim prim
+ (function prim prim prim stub
(array.unsafe_set[addr] prim prim prim))
- (function prim prim
+ (function prim prim stub
(caml_string_compare prim prim))
- (function prim prim
+ (function prim prim stub
(caml_string_equal prim prim))
- (function prim prim
+ (function prim prim stub
(caml_string_notequal prim prim))
- (function prim prim
+ (function prim prim stub
(caml_string_lessthan prim prim))
- (function prim prim
+ (function prim prim stub
(caml_string_greaterthan prim prim))
- (function prim prim
+ (function prim prim stub
(caml_string_lessequal prim prim))
- (function prim prim
+ (function prim prim stub
(caml_string_greaterequal prim prim)))
- (makeblock 0 (function prim (array.length[addr] prim))
- (function prim prim (array.get[addr] prim prim))
- (function prim prim
+ (makeblock 0 (function prim stub (array.length[addr] prim))
+ (function prim prim stub
+ (array.get[addr] prim prim))
+ (function prim prim stub
(array.unsafe_get[addr] prim prim))
- (function prim prim prim
+ (function prim prim prim stub
(array.set[addr] prim prim prim))
- (function prim prim prim
+ (function prim prim prim stub
(array.unsafe_set[addr] prim prim prim))
- (function prim prim
+ (function prim prim stub
(caml_int32_compare prim prim))
- (function prim prim (Int32.== prim prim))
- (function prim prim (Int32.!= prim prim))
- (function prim prim (Int32.< prim prim))
- (function prim prim (Int32.> prim prim))
- (function prim prim (Int32.<= prim prim))
- (function prim prim (Int32.>= prim prim)))
- (makeblock 0 (function prim (array.length[addr] prim))
- (function prim prim (array.get[addr] prim prim))
- (function prim prim
+ (function prim prim stub (Int32.== prim prim))
+ (function prim prim stub (Int32.!= prim prim))
+ (function prim prim stub (Int32.< prim prim))
+ (function prim prim stub (Int32.> prim prim))
+ (function prim prim stub (Int32.<= prim prim))
+ (function prim prim stub (Int32.>= prim prim)))
+ (makeblock 0 (function prim stub (array.length[addr] prim))
+ (function prim prim stub
+ (array.get[addr] prim prim))
+ (function prim prim stub
(array.unsafe_get[addr] prim prim))
- (function prim prim prim
+ (function prim prim prim stub
(array.set[addr] prim prim prim))
- (function prim prim prim
+ (function prim prim prim stub
(array.unsafe_set[addr] prim prim prim))
- (function prim prim
+ (function prim prim stub
(caml_int64_compare prim prim))
- (function prim prim (Int64.== prim prim))
- (function prim prim (Int64.!= prim prim))
- (function prim prim (Int64.< prim prim))
- (function prim prim (Int64.> prim prim))
- (function prim prim (Int64.<= prim prim))
- (function prim prim (Int64.>= prim prim)))
- (makeblock 0 (function prim (array.length[addr] prim))
- (function prim prim (array.get[addr] prim prim))
- (function prim prim
+ (function prim prim stub (Int64.== prim prim))
+ (function prim prim stub (Int64.!= prim prim))
+ (function prim prim stub (Int64.< prim prim))
+ (function prim prim stub (Int64.> prim prim))
+ (function prim prim stub (Int64.<= prim prim))
+ (function prim prim stub (Int64.>= prim prim)))
+ (makeblock 0 (function prim stub (array.length[addr] prim))
+ (function prim prim stub
+ (array.get[addr] prim prim))
+ (function prim prim stub
(array.unsafe_get[addr] prim prim))
- (function prim prim prim
+ (function prim prim prim stub
(array.set[addr] prim prim prim))
- (function prim prim prim
+ (function prim prim prim stub
(array.unsafe_set[addr] prim prim prim))
- (function prim prim
+ (function prim prim stub
(caml_nativeint_compare prim prim))
- (function prim prim (Nativeint.== prim prim))
- (function prim prim (Nativeint.!= prim prim))
- (function prim prim (Nativeint.< prim prim))
- (function prim prim (Nativeint.> prim prim))
- (function prim prim (Nativeint.<= prim prim))
- (function prim prim (Nativeint.>= prim prim))))))
+ (function prim prim stub
+ (Nativeint.== prim prim))
+ (function prim prim stub
+ (Nativeint.!= prim prim))
+ (function prim prim stub (Nativeint.< prim prim))
+ (function prim prim stub (Nativeint.> prim prim))
+ (function prim prim stub
+ (Nativeint.<= prim prim))
+ (function prim prim stub
+ (Nativeint.>= prim prim))))))
+(* Ignore OCAMLRUNPARAM=b to be reproducible *)
+Printexc.record_backtrace false;;
(* By using two types we can have a recursive constraint *)
type 'a class_name = .. constraint 'a = < cast: 'a. 'a name -> 'a; ..>
+# - : unit = ()
# type 'b class_name = .. constraint 'b = < cast : 'a. 'a name -> 'a; .. >
and 'a name =
Class : 'a class_name -> (< cast : 'a0. 'a0 name -> 'a0; .. > as 'a) name
+(* Ignore OCAMLRUNPARAM=b to be reproducible *)
+Printexc.record_backtrace false;;
type foo = ..
;;
+# - : unit = ()
# type foo = ..
# type foo += A | B of int
# val is_a : foo -> bool = <fun>
type foo += B3 = M.B1 (* Error: rebind private extension *)
^^^^
Error: The constructor M.B1 is private
-# Characters 13-24:
+# Characters 17-24:
type foo += C = Unknown (* Error: unbound extension *)
- ^^^^^^^^^^^
+ ^^^^^^^
Error: Unbound constructor Unknown
# module M : sig type foo type foo += A1 of int end
type M.foo += A2 of int
--- /dev/null
+type (_, _) eq = Refl : ('a, 'a) eq;;
+type empty = (int, unit) eq;;
+[%%expect{|
+type (_, _) eq = Refl : ('a, 'a) eq
+type empty = (int, unit) eq
+|}]
+let f (x : ('a, empty Lazy.t) result) =
+ match x with
+ | Ok x -> x
+ | Error (lazy _) -> .;;
+[%%expect{|
+Line _, characters 4-18:
+Error: This match case could not be refuted.
+ Here is an example of a value that would reach it: Error lazy _
+|}]
+let f (x : ('a, empty Lazy.t) result) =
+ match x with
+ | Ok x -> x
+ | Error (lazy Refl) -> .;;
+[%%expect{|
+Line _, characters 16-20:
+Error: This pattern matches values of type (int, int) eq
+ but a pattern was expected which matches values of type
+ empty = (int, unit) eq
+ Type int is not compatible with type unit
+|}]
--- /dev/null
+#labels false;;
+type (_,_) eql = Refl : ('a, 'a) eql
+type s = x:int -> y:float -> unit
+type t = y:int -> x:float -> unit
+type silly = {silly: 'a.'a};;
+let eql : (s, t) eql = Refl;;
+[%%expect{|
+type (_, _) eql = Refl : ('a, 'a) eql
+type s = x:int -> y:float -> unit
+type t = y:int -> x:float -> unit
+type silly = { silly : 'a. 'a; }
+val eql : (s, t) eql = Refl
+|}]
+
+#labels true;;
+let f : [`L of (s, t) eql | `R of silly] -> 'a =
+ function `R {silly} -> silly
+;;
+[%%expect{|
+Line _, characters 2-30:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+`L Refl
+val f : [ `L of (s, t) eql | `R of silly ] -> 'a = <fun>
+|}]
+
+(* Segfault: let () = print_endline (f (`L eql)) *)
val cardinal : 'a t -> int
val bindings : 'a t -> (key * 'a) list
val min_binding : 'a t -> key * 'a
+ val min_binding_opt : 'a t -> (key * 'a) option
val max_binding : 'a t -> key * 'a
+ val max_binding_opt : 'a t -> (key * 'a) option
val choose : 'a t -> key * 'a
+ val choose_opt : 'a t -> (key * 'a) option
val split : key -> 'a t -> 'a t * 'a option * 'a t
val find : key -> 'a t -> 'a
+ val find_opt : key -> 'a t -> 'a option
+ val find_first : (key -> bool) -> 'a t -> key * 'a
+ val find_first_opt : (key -> bool) -> 'a t -> (key * 'a) option
+ val find_last : (key -> bool) -> 'a t -> key * 'a
+ val find_last_opt : (key -> bool) -> 'a t -> (key * 'a) option
val map : ('a -> 'b) -> 'a t -> 'b t
val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
type data
val cardinal : 'a t -> int
val bindings : 'a t -> (key * 'a) list
val min_binding : 'a t -> key * 'a
+ val min_binding_opt : 'a t -> (key * 'a) option
val max_binding : 'a t -> key * 'a
+ val max_binding_opt : 'a t -> (key * 'a) option
val choose : 'a t -> key * 'a
+ val choose_opt : 'a t -> (key * 'a) option
val split : key -> 'a t -> 'a t * 'a option * 'a t
val find : key -> 'a t -> 'a
+ val find_opt : key -> 'a t -> 'a option
+ val find_first : (key -> bool) -> 'a t -> key * 'a
+ val find_first_opt : (key -> bool) -> 'a t -> (key * 'a) option
+ val find_last : (key -> bool) -> 'a t -> key * 'a
+ val find_last_opt : (key -> bool) -> 'a t -> (key * 'a) option
val map : ('a -> 'b) -> 'a t -> 'b t
val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
type data = string
Error: Unbound record field Complex.z
|}];;
-
(* PR#6608 *)
-{ "reference" with contents = 0 }
+{ true 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}
+Line _, characters 2-6:
+Error: This expression has type bool but an expression was expected of type
+ 'a ref
|}];;
-{ true with contents = 0 }
+
+type ('a, 'b) t = { fst : 'a; snd : 'b };;
+let with_fst r fst = { r with fst };;
+with_fst { fst=""; snd="" } 2;;
[%%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}
+type ('a, 'b) t = { fst : 'a; snd : 'b; }
+val with_fst : ('a, 'b) t -> 'c -> ('c, 'b) t = <fun>
+- : (int, string) t = {fst = 2; snd = ""}
|}];;
--- /dev/null
+module type T = sig
+ type t
+ val x : t
+ val show : t -> string
+end
+
+module Int = struct
+ type t = int
+ let x = 0
+ let show x = string_of_int x
+end
+
+module String = struct
+ type t = string
+ let x = "Hello"
+ let show x = x
+end
+
+let switch = ref true
+
+module Choose () = struct
+ module Choice =
+ (val if !switch then (module Int : T)
+ else (module String : T))
+ let r = ref (ref [])
+end
+
+module type S = sig
+ module Choice : T
+ val r : Choice.t list ref ref
+end
+
+module Force (X : functor () -> S) = struct end
+
+module M = Choose ()
+
+let () = switch := false
+
+module N = Choose ()
+
+let () = N.r := !M.r
+;;
+
+module Ignore = Force(Choose)
+;; (* fail *)
+
+(* would cause segfault
+module M' = (M : S)
+
+let () = (!M'.r) := [M'.Choice.x]
+
+module N' = (N : S)
+
+let () = List.iter (fun x -> print_string (N'.Choice.show x)) !(!N'.r)
+*)
val cardinal : t -> int
val elements : t -> elt list
val min_elt : t -> elt
+ val min_elt_opt : t -> elt option
val max_elt : t -> elt
+ val max_elt_opt : t -> elt option
val choose : t -> elt
+ val choose_opt : t -> elt option
val split : elt -> t -> t * bool * t
val find : elt -> t -> elt
+ val find_opt : elt -> t -> elt option
+ val find_first : (elt -> bool) -> t -> elt
+ val find_first_opt : (elt -> bool) -> t -> elt option
+ val find_last : (elt -> bool) -> t -> elt
+ val find_last_opt : (elt -> bool) -> t -> elt option
val of_list : elt list -> t
end
module SSet :
val cardinal : t -> int
val elements : t -> elt list
val min_elt : t -> elt
+ val min_elt_opt : t -> elt option
val max_elt : t -> elt
+ val max_elt_opt : t -> elt option
val choose : t -> elt
+ val choose_opt : t -> elt option
val split : elt -> t -> t * bool * t
val find : elt -> t -> elt
+ val find_opt : elt -> t -> elt option
+ val find_first : (elt -> bool) -> t -> elt
+ val find_first_opt : (elt -> bool) -> t -> elt option
+ val find_last : (elt -> bool) -> t -> elt
+ val find_last_opt : (elt -> bool) -> t -> elt option
val of_list : elt list -> t
end
val f : StringSet.t -> SSet.t = <fun>
val cardinal : t -> int
val elements : t -> elt list
val min_elt : t -> elt
+ val min_elt_opt : t -> elt option
val max_elt : t -> elt
+ val max_elt_opt : t -> elt option
val choose : t -> elt
+ val choose_opt : t -> elt option
val split : elt -> t -> t * bool * t
val find : elt -> t -> elt
+ val find_opt : elt -> t -> elt option
+ val find_first : (elt -> bool) -> t -> elt
+ val find_first_opt : (elt -> bool) -> t -> elt option
+ val find_last : (elt -> bool) -> t -> elt
+ val find_last_opt : (elt -> bool) -> t -> elt option
val of_list : elt list -> t
end
val empty : S.t
val cardinal : t -> int
val elements : t -> elt list
val min_elt : t -> elt
+ val min_elt_opt : t -> elt option
val max_elt : t -> elt
+ val max_elt_opt : t -> elt option
val choose : t -> elt
+ val choose_opt : t -> elt option
val split : elt -> t -> t * bool * t
val find : elt -> t -> elt
+ val find_opt : elt -> t -> elt option
+ val find_first : (elt -> bool) -> t -> elt
+ val find_first_opt : (elt -> bool) -> t -> elt option
+ val find_last : (elt -> bool) -> t -> elt
+ val find_last_opt : (elt -> bool) -> t -> elt option
val of_list : elt list -> t
end
type (_, _) eq = Eq : ('a, 'a) eq
--- /dev/null
+module F (X : sig type t = private < foo:int; ..> val x : t end) = struct
+ let x : < foo: int; ..> = X.x
+end;;
+[%%expect{|
+module F :
+ functor (X : sig type t = private < foo : int; .. > val x : t end) ->
+ sig val x : X.t end
+|}]
+
+module M = struct
+ type t = < foo: int; bar: int>
+ let x = object
+ method foo = 0
+ method bar = 0
+ end
+end;;
+[%%expect{|
+module M :
+ sig type t = < bar : int; foo : int > val x : < bar : int; foo : int > end
+|}]
+
+module N = F(M);;
+[%%expect{|
+module N : sig val x : M.t end
+|}]
+
+module A : sig end = struct
+ module F (X : sig type t = private < foo:int; ..> val x : t end) = struct
+ let x : < foo: int; ..> = X.x
+ end
+
+ module N = F(M)
+ let _ = (N.x = M.x)
+end;;
+[%%expect{|
+module A : sig end
+|}]
method f x = (x : bool c)
end..
Error: The abbreviation c is used with parameters bool c
- wich are incompatible with constraints int c
+ which are incompatible with constraints int c
# class ['a, 'b] c :
unit ->
object
method f x = (x : bool c)
end..
Error: The abbreviation c is used with parameters bool c
- wich are incompatible with constraints int c
+ which are incompatible with constraints int c
# class ['a, 'b] c :
unit ->
object
-# Characters 10-16:
+# Characters 11-16:
let f (x: #M.foo) = 0;;
- ^^^^^^
+ ^^^^^
Error: Unbound module M
#
The type constructor M.t would escape its scope
|}];;
+
+(* PR#6987 *)
+type 'a t = V1 of 'a
+
+type ('c,'t) pvariant = [ `V of ('c * 't t) ]
+
+class ['c] clss =
+ object
+ method mthod : 't . 'c -> 't t -> ('c, 't) pvariant = fun c x ->
+ `V (c, x)
+ end;;
+
+let f2 = fun o c x -> match x with | V1 _ -> x
+
+let rec f1 o c x =
+ match (o :> _ clss)#mthod c x with
+ | `V c -> f2 o c x;;
+[%%expect{|
+type 'a t = V1 of 'a
+type ('c, 't) pvariant = [ `V of 'c * 't t ]
+class ['c] clss : object method mthod : 'c -> 't t -> ('c, 't) pvariant end
+val f2 : 'a -> 'b -> 'c t -> 'c t = <fun>
+val f1 :
+ < mthod : 't. 'a -> 't t -> [< ('a, 't) pvariant ]; .. > ->
+ 'a -> 'b t -> 'b t = <fun>
+|}]
+
(* PR#7285 *)
type (+'a,-'b) foo = private int;;
let f (x : int) : ('a,'a) foo = Obj.magic x;;
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; .. >;;
+
+(* PR#7437 *)
+type t = [` Closed ];;
+type nonrec t = private [> t];;
+
type 'a t
Their constraints differ.
# type 'a t = private 'a constraint 'a = < x : int; .. >
-#
+# type t = [ `Closed ]
+# type nonrec t = private [> t ]
+#
type 'a t
Their constraints differ.
# type 'a t = private 'a constraint 'a = < x : int; .. >
-#
+# type t = [ `Closed ]
+# type nonrec t = private [> t ]
+#
# type t = [ `A | `B ]
# type 'a u = t
-# val a : [< int u > `A ] = `A
+# val a : [< t > `A ] = `A
# type 'a s = 'a
# val b : [< t > `B ] = `B
#
val cardinal : 'a t -> key
val bindings : 'a t -> (key * 'a) list
val min_binding : 'a t -> key * 'a
+ val min_binding_opt : 'a t -> (key * 'a) option
val max_binding : 'a t -> key * 'a
+ val max_binding_opt : 'a t -> (key * 'a) option
val choose : 'a t -> key * 'a
+ val choose_opt : 'a t -> (key * 'a) option
val split : key -> 'a t -> 'a t * 'a option * 'a t
val find : key -> 'a t -> 'a
+ val find_opt : key -> 'a t -> 'a option
+ val find_first : (key -> bool) -> 'a t -> key * 'a
+ val find_first_opt : (key -> bool) -> 'a t -> (key * 'a) option
+ val find_last : (key -> bool) -> 'a t -> key * 'a
+ val find_last_opt : (key -> bool) -> 'a t -> (key * 'a) option
val map : ('a -> 'b) -> 'a t -> 'b t
val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
end
end = struct
type t = A of int [@@ocaml.unboxed]
end;;
+
+(* regression test for PR#7511 (wrong determination of unboxability for GADTs)
+*)
+type 'a s = S : 'a -> 'a s [@@unboxed];;
+type t = T : _ s -> t [@@unboxed];;
+
+(* regression test for GPR#1133 (follow-up to PR#7511) *)
+type 'a s = S : 'a -> 'a option s [@@unboxed];;
+type t = T : _ s -> t [@@unboxed];;
+
+(* Another test for GPR#1133: abstract types *)
+module M : sig
+ type 'a r constraint 'a = unit -> 'b
+ val inj : 'b -> (unit -> 'b) r
+end = struct
+ type 'a r = 'b constraint 'a = unit -> 'b
+ let inj x = x
+end;;
+
+(* reject *)
+type t = T : (unit -> _) M.r -> t [@@unboxed];;
+
+type 'a s = S : (unit -> 'a) M.r -> 'a option s [@@unboxed];;
+
+(* reject *)
+type t = T : _ s -> t [@@unboxed];;
+
+(* accept *)
+type 'a t = T : 'a s -> 'a t [@@unboxed];;
+
+
+(* Another corner case from GPR#1133 *)
+type _ s = S : 'a t -> _ s [@@unboxed]
+ and _ t = T : 'a -> 'a s t
+;;
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 19-69:
+ type t18 = A : _ list abs -> t18 [@@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].
# * Characters 176-256:
......struct
type t = A of float [@@ocaml.unboxed]
Their internal representations differ:
the first declaration uses unboxed float representation.
# * * module T : sig type t [@@immediate] end
+# * type 'a s = S : 'a -> 'a s [@@unboxed]
+# Characters 0-33:
+ type t = T : _ s -> t [@@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 'a s = S : 'a -> 'a option s [@@unboxed]
+# Characters 0-33:
+ type t = T : _ s -> t [@@unboxed];;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because
+ it might contain both float and non-float values.
+ You should annotate it with [@@ocaml.boxed].
+# module M :
+ sig type 'a r constraint 'a = unit -> 'b val inj : 'b -> (unit -> 'b) r end
+# Characters 14-59:
+ type t = T : (unit -> _) M.r -> t [@@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 'a s = S : (unit -> 'a) M.r -> 'a option s [@@unboxed]
+# Characters 14-47:
+ type t = T : _ s -> t [@@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 'a t = T : 'a s -> 'a t [@@unboxed]
+# Characters 42-81:
+ type _ s = S : 'a t -> _ s [@@unboxed]
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because
+ it might contain both float and non-float values.
+ You should annotate it with [@@ocaml.boxed].
#
external r : int -> (int[@untagged]) = "r";;
external s : int -> int = "s" [@@untagged];;
external t : float -> float = "t" [@@unboxed];;
+
+(* PR#7424 *)
+type 'a b = B of 'a b b [@@unboxed];;
external t : float -> float = "t" [@@unboxed];;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: The native code version of the primitive is mandatory when attributes [@untagged] or [@unboxed] are present
+# type 'a b = B of 'a b b [@@unboxed]
#
+(* Ignore OCAMLRUNPARAM=b to be reproducible *)
+Printexc.record_backtrace false;;
+
let () = print_endline "\n\
<----------------------------------------------------------------------\n\
To check the result file for this test, it suffices to look for \"val\"\n\
-#
+# - : unit = ()
+#
<----------------------------------------------------------------------
To check the result file for this test, it suffices to look for "val"
lines corresponding to toplevel answers. If they start with
variable x may match different arguments. (See manual section 8.5)
val ambiguous_typical_example : expr * expr -> unit = <fun>
# Note that an Assert_failure is expected just below.
-# Exception: Assert_failure ("//toplevel//", 23, 6).
+# Exception: Assert_failure ("//toplevel//", 25, 6).
# val not_ambiguous__no_orpat : int option -> unit = <fun>
# val not_ambiguous__no_guard : [< `A | `B | `C ] -> unit = <fun>
# val not_ambiguous__no_patvar_in_guard :
+(* Ignore OCAMLRUNPARAM=b to be reproducible *)
+Printexc.record_backtrace false;;
+
let _ = ignore (+);;
let _ = raise Exit 3;;
-# Characters 15-18:
+# - : unit = ()
+# Characters 16-19:
let _ = ignore (+);;
^^^
Warning 5: this function application is partial,
(* #7059, all clauses guarded *)
let f x y = match 1 with 1 when x = y -> 1;;
+
+(* #7504, Example with no constraints on a record *)
+let f = function {contents=_}, 0 -> 0;;
Warning 8: this pattern-matching is not exhaustive.
All clauses in this pattern-matching are guarded.
val f : 'a -> 'a -> int = <fun>
+# Characters 62-91:
+ let f = function {contents=_}, 0 -> 0;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(_, 1)
+val f : 'a ref * int -> int = <fun>
#
+(* Ignore OCAMLRUNPARAM=b to be reproducible *)
+Printexc.record_backtrace false;;
+
exception A;;
type a = A;;
-# exception A
+# - : unit = ()
+# exception A
# type a = A
# Characters 1-2:
A;;
-# exception A
+# - : unit = ()
+# exception A
# type a = A
# Characters 1-2:
A;;
+(* Ignore OCAMLRUNPARAM=b to be reproducible *)
+Printexc.record_backtrace false;;
+
let () = raise Exit; () ;; (* warn *)
-# Characters 9-19:
+# - : unit = ()
+# Characters 10-20:
let () = raise Exit; () ;; (* warn *)
^^^^^^^^^^
Warning 21: this statement never returns (or has an unsound type.)
type t += Private_ext
end
;;
+
+module Pr7438 : sig
+end = struct
+ module type S = sig type t = private [> `Foo] end
+ module type X = sig type t = private [> `Foo | `Bar] include S with type t := t end
+end;;
It is exported or rebound as a private extension.
module Unused_private_extension :
sig type t = .. type t += private Private_ext end
+# module Pr7438 : sig end
#
@$(OCAMLOPT) -c -opaque mylib.mli
@$(OCAMLOPT) -c driver.ml
@$(OCAMLOPT) -c mylib.ml
- @$(OCAMLOPT) -c stack_walker.c
+ @$(OCAMLOPT) -ccopt "-I$(CTOPDIR)/byterun" -c stack_walker.c
@$(OCAMLOPT) -cclib -Wl,-keep_dwarf_unwind -o unwind_test mylib.cmx \
driver.cmx stack_walker.o
run-all:
@$(OCAMLC) $(FLAGS) -c deprecated_module.mli
@$(OCAMLC) $(FLAGS) -c module_without_cmx.mli
+ @$(OCAMLC) $(FLAGS) -c w60.mli
@for file in *.ml; do \
printf " ... testing '$$file':"; \
F="`basename $$file .ml`"; \
--- /dev/null
+[@@@ocaml.warning "+4"]
+
+type expr = E of int [@@unboxed]
+
+
+let f x = match x with (E e) -> e
+
+type t = A | B
+
+let g x = match x with
+| A -> 0
+| _ -> 1
--- /dev/null
+File "w04.ml", line 10, characters 10-40:
+Warning 4: this pattern-matching is fragile.
+It will remain exhaustive when constructors are added to type t.
--- /dev/null
+(** Test unused opens, in particular in presence of
+ pattern open *)
+
+module M = struct end
+module N = struct type t = A | B end
+module R = struct type r = {x: int} end
+
+let f M.(x) = x (* useless open *)
+let g N.(A|B) = () (* used open *)
+let h R.{x} = R.{x}
+
+open N (* used open *)
+let i (A|B) = B
+
+open! M (* open! also deactivates unused open warning *)
+open M (* useless open *)
--- /dev/null
+File "w33.ml", line 8, characters 6-11:
+Warning 33: unused open M.
+File "w33.ml", line 16, characters 0-6:
+Warning 33: unused open M.
--- /dev/null
+(* PR#7314 *)
+
+module type Comparable = sig
+ val id: int
+end
+
+module Make_graph (P:sig module Id:Comparable end) = struct
+ let foo = P.Id.id
+end
+
+module Fold_ordered(P: sig module Id:Comparable end) =
+struct
+ include Make_graph(struct module Id = P.Id end)
+end
+
+
+(* PR#7314 *)
+
+module M = struct
+ module N = struct end
+end
+
+module O = M.N
--- /dev/null
+module type Comparable = sig
+ val id: int
+end
+
+module Fold_ordered(P: sig module Id:Comparable end): sig
+ val foo: int
+end
+
+
+
+module M : sig end
+module O : sig end
../parsing/location.cmi ../parsing/asttypes.cmi
eqparsetree.cmx : ../parsing/parsetree.cmi ../parsing/longident.cmx \
../parsing/location.cmx ../parsing/asttypes.cmi
-objinfo.cmo : ../asmcomp/printclambda.cmi ../utils/misc.cmi \
+lintapidiff.cmo : ../typing/printtyp.cmi ../driver/pparse.cmi \
+ ../typing/path.cmi ../parsing/parsetree.cmi ../parsing/parse.cmi \
+ ../utils/misc.cmi ../parsing/location.cmi ../typing/ident.cmi
+lintapidiff.cmx : ../typing/printtyp.cmx ../driver/pparse.cmx \
+ ../typing/path.cmx ../parsing/parsetree.cmi ../parsing/parse.cmx \
+ ../utils/misc.cmx ../parsing/location.cmx ../typing/ident.cmx
+make_opcodes.cmo :
+make_opcodes.cmx :
+objinfo.cmo : ../utils/tbl.cmi ../middle_end/base_types/symbol.cmi \
+ ../asmcomp/printclambda.cmi ../utils/misc.cmi \
../middle_end/base_types/linkage_name.cmi ../typing/ident.cmi \
../asmcomp/export_info.cmi ../utils/config.cmi \
../middle_end/base_types/compilation_unit.cmi ../asmcomp/cmx_format.cmi \
../typing/cmt_format.cmi ../bytecomp/cmo_format.cmi \
../typing/cmi_format.cmi ../bytecomp/bytesections.cmi
-objinfo.cmx : ../asmcomp/printclambda.cmx ../utils/misc.cmx \
+objinfo.cmx : ../utils/tbl.cmx ../middle_end/base_types/symbol.cmx \
+ ../asmcomp/printclambda.cmx ../utils/misc.cmx \
../middle_end/base_types/linkage_name.cmx ../typing/ident.cmx \
../asmcomp/export_info.cmx ../utils/config.cmx \
../middle_end/base_types/compilation_unit.cmx ../asmcomp/cmx_format.cmi \
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 \
- ../parsing/depend.cmi ../utils/config.cmi ../driver/compenv.cmi \
- ../utils/clflags.cmi
+ ../parsing/depend.cmi ../utils/config.cmi ../driver/compplugin.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 \
- ../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
+ ../parsing/depend.cmx ../utils/config.cmx ../driver/compplugin.cmx \
+ ../driver/compenv.cmx ../utils/clflags.cmx
+ocamlmklib.cmo : ocamlmklibconfig.cmo ../utils/misc.cmi ../utils/config.cmi
+ocamlmklib.cmx : ocamlmklibconfig.cmx ../utils/misc.cmx ../utils/config.cmx
ocamlmklibconfig.cmo :
ocamlmklibconfig.cmx :
ocamlmktop.cmo : ../utils/ccomp.cmi
#* *
#**************************************************************************
-include Makefile.shared
+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
+
+# 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
+ifeq "$(UNIX_OR_WIN32)" "win32"
+ ifneq "$(wildcard ../flexdll/Makefile)" ""
+ CAMLOPT := OCAML_FLEXLINK="../boot/ocamlrun ../flexdll/flexlink.exe" \
+ $(CAMLOPT)
+ endif
+endif
+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= -absname -w +a-4-9-41-42-44-45-48 -strict-sequence -warn-error A \
+ -safe-string -strict-formats -bin-annot $(INCLUDES)
+LINKFLAGS=$(INCLUDES)
+VPATH := $(filter-out -I,$(INCLUDES))
+
+# scrapelabels addlabels
+
+.PHONY: all opt.opt
+
+# The dependency generator
+
+CAMLDEP_OBJ=ocamldep.cmo
+CAMLDEP_IMPORTS= \
+ ../compilerlibs/ocamlcommon.cma \
+ ../compilerlibs/ocamlbytecomp.cma
+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
+clean::
+ if test -f ocamldep; then mv -f ocamldep ocamldep.bak; else :; fi
+ rm -f ocamldep.opt
+
+
+# The profiler
+
+CSLPROF=ocamlprof.cmo
+CSLPROF_IMPORTS=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
+
+$(call byte_and_opt,ocamlprof,$(CSLPROF_IMPORTS) profiling.cmo $(CSLPROF),)
+
+ocamlcp_cmos = misc.cmo warnings.cmo config.cmo identifiable.cmo numbers.cmo \
+ arg_helper.cmo clflags.cmo main_args.cmo
+
+$(call byte_and_opt,ocamlcp,$(ocamlcp_cmos) ocamlcp.cmo,)
+$(call byte_and_opt,ocamloptp,$(ocamlcp_cmos) ocamloptp.cmo,)
+
+opt:: profiling.cmx
+
+install::
+ cp -- profiling.cmi profiling.cmo profiling.cmt profiling.cmti "$(INSTALL_LIBDIR)"
+
+installopt::
+ cp -- profiling.cmx profiling.$(O) "$(INSTALL_LIBDIR)"
+
+# To help building mixed-mode libraries (OCaml + C)
+
+$(call byte_and_opt,ocamlmklib,ocamlmklibconfig.cmo config.cmo misc.cmo \
+ ocamlmklib.cmo,)
+
+
+ocamlmklibconfig.ml: ../config/Makefile Makefile
+ (echo 'let bindir = "$(BINDIR)"'; \
+ echo 'let supports_shared_libraries = $(SUPPORTS_SHARED_LIBRARIES)';\
+ echo 'let byteccrpath = "$(BYTECCRPATH)"'; \
+ echo 'let nativeccrpath = "$(NATIVECCRPATH)"'; \
+ echo 'let mksharedlibrpath = "$(MKSHAREDLIBRPATH)"'; \
+ echo 'let toolpref = "$(TOOLPREF)"'; \
+ sed -n -e 's/^#ml //p' ../config/Makefile) \
+ > ocamlmklibconfig.ml
+
+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
+LIBRARY3= misc.cmo warnings.cmo location.cmo
+
+ocaml299to3: $(OCAML299TO3)
+ $(CAMLC) $(LINKFLAGS) -o ocaml299to3 $(LIBRARY3) $(OCAML299TO3)
+
+lexer299.ml: lexer299.mll
+ $(CAMLLEX) lexer299.mll
+
+#install::
+# cp ocaml299to3 "$(INSTALL_BINDIR)/ocaml299to3$(EXE)"
+
+clean::
+ rm -f ocaml299to3 lexer299.ml
+
+# Label remover for interface files (upgrade 3.02 to 3.03)
+
+SCRAPELABELS= lexer301.cmo scrapelabels.cmo
+
+scrapelabels: $(SCRAPELABELS)
+ $(CAMLC) $(LINKFLAGS) -o scrapelabels $(LIBRARY3) $(SCRAPELABELS)
+
+lexer301.ml: lexer301.mll
+ $(CAMLLEX) lexer301.mll
+
+#install::
+# cp scrapelabels "$(INSTALL_LIBDIR)"
+
+clean::
+ rm -f scrapelabels lexer301.ml
+
+# Insert labels following an interface file (upgrade 3.02 to 3.03)
+
+ADDLABELS_IMPORTS=misc.cmo config.cmo arg_helper.cmo clflags.cmo \
+ identifiable.cmo numbers.cmo terminfo.cmo \
+ warnings.cmo location.cmo longident.cmo docstrings.cmo \
+ syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo
+
+addlabels: addlabels.cmo
+ $(CAMLC) $(LINKFLAGS) -w sl -o addlabels \
+ $(ADDLABELS_IMPORTS) 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
+
+# The preprocessor for asm generators
+
+CVT_EMIT=cvt_emit.cmo
+
+cvt_emit: $(CVT_EMIT)
+ $(CAMLC) $(LINKFLAGS) -o 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
+
+cvt_emit.ml: cvt_emit.mll
+ $(CAMLLEX) cvt_emit.mll
+
+clean::
+ rm -f cvt_emit.ml
+
+beforedepend:: cvt_emit.ml
+
+# Reading cmt files
+
+READ_CMT= \
+ ../compilerlibs/ocamlcommon.cma \
+ ../compilerlibs/ocamlbytecomp.cma \
+ \
+ cmt2annot.cmo read_cmt.cmo
+
+# Reading cmt files
+$(call byte_and_opt,read_cmt,$(READ_CMT),)
+
+
+# The bytecode disassembler
+
+DUMPOBJ=opnames.cmo dumpobj.cmo
+
+$(call byte_and_opt,dumpobj,misc.cmo identifiable.cmo numbers.cmo tbl.cmo \
+ config.cmo ident.cmo opcodes.cmo bytesections.cmo \
+ $(DUMPOBJ),)
+
+make_opcodes.ml: make_opcodes.mll
+ $(CAMLLEX) make_opcodes.mll
+
+make_opcodes: make_opcodes.ml
+ $(CAMLC) make_opcodes.ml -o $@
+
+opnames.ml: ../byterun/caml/instruct.h make_opcodes
+ $(CAMLRUN) make_opcodes -opnames < $< > $@
+
+clean::
+ rm -f opnames.ml make_opcodes make_opcodes.ml
+
+beforedepend:: opnames.ml
+
+# Display info on compiled files
+
+ifeq "$(SYSTEM)" "macosx"
+DEF_SYMBOL_PREFIX = '-Dsymbol_prefix="_"'
+else
+DEF_SYMBOL_PREFIX = '-Dsymbol_prefix=""'
+endif
+
+ifeq "$(CCOMPTYPE)" "msvc"
+CCOUT = -Fe
+else
+EMPTY =
+CCOUT = -o $(EMPTY)
+endif
+
+objinfo_helper$(EXE): objinfo_helper.c ../config/s.h
+ $(BYTECC) $(CCOUT)objinfo_helper$(EXE) $(BYTECCCOMPOPTS) \
+ $(DEF_SYMBOL_PREFIX) $(LIBBFD_INCLUDE) objinfo_helper.c $(LIBBFD_LINK)
+
+OBJINFO=../compilerlibs/ocamlcommon.cma \
+ ../compilerlibs/ocamlbytecomp.cma \
+ ../compilerlibs/ocamlmiddleend.cma \
+ ../asmcomp/printclambda.cmo \
+ ../asmcomp/export_info.cmo \
+ objinfo.cmo
+
+$(call byte_and_opt,ocamlobjinfo,$(OBJINFO),objinfo_helper$(EXE))
+
+install::
+ cp objinfo_helper$(EXE) "$(INSTALL_LIBDIR)/objinfo_helper$(EXE)"
+
+# Scan object files for required primitives
+$(call byte_and_opt,primreq,config.cmo primreq.cmo,)
+
+LINTAPIDIFF=../compilerlibs/ocamlcommon.cmxa \
+ ../compilerlibs/ocamlbytecomp.cmxa \
+ ../compilerlibs/ocamlmiddleend.cmxa \
+ ../asmcomp/printclambda.cmx \
+ ../asmcomp/export_info.cmx \
+ ../otherlibs/str/str.cmxa \
+ lintapidiff.cmx
+
+lintapidiff.opt: INCLUDES+= -I ../otherlibs/str
+lintapidiff.opt: $(LINTAPIDIFF)
+ $(CAMLOPT) $(LINKFLAGS) -I .. -o $@ $(LINTAPIDIFF)
+clean::
+ rm -f -- lintapidiff.opt lintapidiff.cm? lintapidiff.o
+
+
+clean::
+ rm -f "objinfo_helper$(EXE)" "objinfo_helper$(EXE).manifest"
+
+
+# Copy a bytecode executable, stripping debug info
+
+stripdebug=../compilerlibs/ocamlcommon.cma \
+ ../compilerlibs/ocamlbytecomp.cma \
+ stripdebug.cmo
+
+$(call byte_and_opt,stripdebug,$(stripdebug),)
+
+# Compare two bytecode executables
+
+CMPBYT=../compilerlibs/ocamlcommon.cma \
+ ../compilerlibs/ocamlbytecomp.cma \
+ cmpbyt.cmo
+
+$(call byte_and_opt,cmpbyt,$(CMPBYT),)
+
+ifeq "$(RUNTIMEI)" "true"
+install::
+ cp ocaml-instr-graph ocaml-instr-report "$(INSTALL_BINDIR)/"
+endif
+
+# Common stuff
+
+.SUFFIXES:
+
+%.cmo: %.ml
+ $(CAMLC) -c $(COMPFLAGS) - $<
+
+%.cmi: %.mli
+ $(CAMLC) -c $(COMPFLAGS) - $<
+
+%.cmx: %.ml
+ $(CAMLOPT) $(COMPFLAGS) -c - $<
+
+clean::
+ rm -f *.cmo *.cmi *.cma *.dll *.so *.lib *.a
+
+depend: beforedepend
+ $(CAMLRUN) ./ocamldep -slash $(INCLUDES) *.mli *.ml > .depend
+
+.PHONY: clean install beforedepend depend
+
+include .depend
#* *
#**************************************************************************
-include Makefile.shared
-
-ifneq "$(wildcard ../flexdll/Makefile)" ""
-CAMLOPT := OCAML_FLEXLINK="../boot/ocamlrun ../flexdll/flexlink.exe" \
- $(CAMLOPT)
-endif
-
-clean::
- rm -f "objinfo_helper$(EXE).manifest"
+include Makefile
+++ /dev/null
-#**************************************************************************
-#* *
-#* 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. *
-#* *
-#**************************************************************************
-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
-
-# 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= -absname -w +a-4-9-41-42-44-45-48 -strict-sequence -warn-error A \
- -safe-string -strict-formats $(INCLUDES)
-LINKFLAGS=$(INCLUDES)
-VPATH := $(filter-out -I,$(INCLUDES))
-
-# scrapelabels addlabels
-
-.PHONY: all opt.opt
-
-# The dependency generator
-
-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 depend.cmo
-
-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
-clean::
- if test -f ocamldep; then mv -f ocamldep ocamldep.bak; else :; fi
- rm -f ocamldep.opt
-
-
-# The profiler
-
-CSLPROF=ocamlprof.cmo
-CSLPROF_IMPORTS=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
-
-$(call byte_and_opt,ocamlprof,$(CSLPROF_IMPORTS) profiling.cmo $(CSLPROF),)
-
-ocamlcp_cmos = misc.cmo warnings.cmo config.cmo identifiable.cmo numbers.cmo \
- arg_helper.cmo clflags.cmo main_args.cmo
-
-$(call byte_and_opt,ocamlcp,$(ocamlcp_cmos) ocamlcp.cmo,)
-$(call byte_and_opt,ocamloptp,$(ocamlcp_cmos) ocamloptp.cmo,)
-
-opt:: profiling.cmx
-
-install::
- cp -- profiling.cmi profiling.cmo "$(INSTALL_LIBDIR)"
-
-installopt::
- cp -- profiling.cmx profiling.$(O) "$(INSTALL_LIBDIR)"
-
-# To help building mixed-mode libraries (OCaml + C)
-
-$(call byte_and_opt,ocamlmklib,ocamlmklibconfig.cmo config.cmo \
- ocamlmklib.cmo,)
-
-
-ocamlmklibconfig.ml: ../config/Makefile Makefile
- (echo 'let bindir = "$(BINDIR)"'; \
- echo 'let supports_shared_libraries = $(SUPPORTS_SHARED_LIBRARIES)';\
- echo 'let byteccrpath = "$(BYTECCRPATH)"'; \
- echo 'let nativeccrpath = "$(NATIVECCRPATH)"'; \
- echo 'let mksharedlibrpath = "$(MKSHAREDLIBRPATH)"'; \
- echo 'let toolpref = "$(TOOLPREF)"'; \
- sed -n -e 's/^#ml //p' ../config/Makefile) \
- > ocamlmklibconfig.ml
-
-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
-LIBRARY3= misc.cmo warnings.cmo location.cmo
-
-ocaml299to3: $(OCAML299TO3)
- $(CAMLC) $(LINKFLAGS) -o ocaml299to3 $(LIBRARY3) $(OCAML299TO3)
-
-lexer299.ml: lexer299.mll
- $(CAMLLEX) lexer299.mll
-
-#install::
-# cp ocaml299to3 "$(INSTALL_BINDIR)/ocaml299to3$(EXE)"
-
-clean::
- rm -f ocaml299to3 lexer299.ml
-
-# Label remover for interface files (upgrade 3.02 to 3.03)
-
-SCRAPELABELS= lexer301.cmo scrapelabels.cmo
-
-scrapelabels: $(SCRAPELABELS)
- $(CAMLC) $(LINKFLAGS) -o scrapelabels $(LIBRARY3) $(SCRAPELABELS)
-
-lexer301.ml: lexer301.mll
- $(CAMLLEX) lexer301.mll
-
-#install::
-# cp scrapelabels "$(INSTALL_LIBDIR)"
-
-clean::
- rm -f scrapelabels lexer301.ml
-
-# Insert labels following an interface file (upgrade 3.02 to 3.03)
-
-ADDLABELS_IMPORTS=misc.cmo config.cmo arg_helper.cmo clflags.cmo \
- identifiable.cmo numbers.cmo terminfo.cmo \
- warnings.cmo location.cmo longident.cmo docstrings.cmo \
- syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo
-
-addlabels: addlabels.cmo
- $(CAMLC) $(LINKFLAGS) -w sl -o addlabels \
- $(ADDLABELS_IMPORTS) 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
-
-# The preprocessor for asm generators
-
-CVT_EMIT=cvt_emit.cmo
-
-cvt_emit: $(CVT_EMIT)
- $(CAMLC) $(LINKFLAGS) -o 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
-
-cvt_emit.ml: cvt_emit.mll
- $(CAMLLEX) cvt_emit.mll
-
-clean::
- rm -f cvt_emit.ml
-
-beforedepend:: cvt_emit.ml
-
-# Reading cmt files
-
-READ_CMT= \
- ../compilerlibs/ocamlcommon.cma \
- ../compilerlibs/ocamlbytecomp.cma \
- \
- cmt2annot.cmo read_cmt.cmo
-
-# Reading cmt files
-$(call byte_and_opt,read_cmt,$(READ_CMT),)
-
-
-# The bytecode disassembler
-
-DUMPOBJ=opnames.cmo dumpobj.cmo
-
-$(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 || : ; \
- unset LC_CTYPE || : ; \
- unset LC_COLLATE LANG || : ; \
- sed -e '/[/][*]/d' \
- -e '/^#/d' \
- -e 's/enum \(.*\) {/let names_of_\1 = [|/' \
- -e 's/.*};$$/ |]/' \
- -e 's/\([A-Z][A-Z_0-9a-z]*\)/"\1"/g' \
- -e 's/,/;/g' \
- ../byterun/caml/instruct.h > opnames.ml
-
-clean::
- rm -f opnames.ml
-
-beforedepend:: opnames.ml
-
-# Display info on compiled files
-
-ifeq "$(SYSTEM)" "macosx"
-DEF_SYMBOL_PREFIX = '-Dsymbol_prefix="_"'
-else
-DEF_SYMBOL_PREFIX = '-Dsymbol_prefix=""'
-endif
-
-ifeq "$(CCOMPTYPE)" "msvc"
-CCOUT = -Fe
-else
-EMPTY =
-CCOUT = -o $(EMPTY)
-endif
-
-objinfo_helper$(EXE): objinfo_helper.c ../config/s.h
- $(BYTECC) $(CCOUT)objinfo_helper$(EXE) $(BYTECCCOMPOPTS) \
- $(DEF_SYMBOL_PREFIX) $(LIBBFD_INCLUDE) objinfo_helper.c $(LIBBFD_LINK)
-
-OBJINFO=../compilerlibs/ocamlcommon.cma \
- ../compilerlibs/ocamlbytecomp.cma \
- ../compilerlibs/ocamlmiddleend.cma \
- ../asmcomp/printclambda.cmo \
- ../asmcomp/export_info.cmo \
- objinfo.cmo
-
-$(call byte_and_opt,ocamlobjinfo,$(OBJINFO),objinfo_helper$(EXE))
-
-install::
- cp objinfo_helper$(EXE) "$(INSTALL_LIBDIR)/objinfo_helper$(EXE)"
-
-# Scan object files for required primitives
-$(call byte_and_opt,primreq,config.cmo primreq.cmo,)
-
-clean::
- rm -f "objinfo_helper$(EXE)"
-
-
-# Copy a bytecode executable, stripping debug info
-
-stripdebug=../compilerlibs/ocamlcommon.cma \
- ../compilerlibs/ocamlbytecomp.cma \
- stripdebug.cmo
-
-$(call byte_and_opt,stripdebug,$(stripdebug),)
-
-# Compare two bytecode executables
-
-CMPBYT=../compilerlibs/ocamlcommon.cma \
- ../compilerlibs/ocamlbytecomp.cma \
- cmpbyt.cmo
-
-$(call byte_and_opt,cmpbyt,$(CMPBYT),)
-
-ifeq "$(RUNTIMEI)" "true"
-install::
- cp ocaml-instr-graph ocaml-instr-report "$(INSTALL_BINDIR)/"
-endif
-
-# Common stuff
-
-.SUFFIXES:
-
-%.cmo: %.ml
- $(CAMLC) -c $(COMPFLAGS) - $<
-
-%.cmi: %.mli
- $(CAMLC) -c $(COMPFLAGS) - $<
-
-%.cmx: %.ml
- $(CAMLOPT) $(COMPFLAGS) -c - $<
-
-clean::
- rm -f *.cmo *.cmi *.cma *.dll *.so *.lib *.a
-
-depend: beforedepend
- $(CAMLRUN) ./ocamldep -slash $(INCLUDES) *.mli *.ml > .depend
-
-.PHONY: clean install beforedepend depend
-
-include .depend
ocamldoc/*|*/ocamldoc/*) rules="long-line,$rules";;
esac
- (cat "$f"; echo) \
+ (cat "$f" | tr -d '\r'; echo) \
| awk -v rules="$rules" -v svnrules="$svnrules" -v file="$f" \
'
function err(name, msg) {
# This script is run on our continuous-integration servers to recompile
# from scratch and run the test suite.
+# To know the slave's architecture, this script looks at the OCAML_ARCH
+# environment variable. For a given node NODe, this variable can be defined
+# in Jenkins at the following address:
+# https://ci.inria.fr/ocaml/computer/NODE/configure
+
# arguments:
-# 1. architecture: bsd, macos, linux, cygwin, mingw, mingw64, msvc, msvc64
-# 2. directory in which to build (trunk, 4.02, etc)
-# 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 add configure-option to configure cmd line
-# -patch1 file-name apply patch with -p1
-# -newmakefiles do not use Makefile.nt even for Windows
+# -conf configure-option add configure-option to configure cmd line
+# -patch1 file-name apply patch with -p1
+# -no-native do not build "opt" and "opt.opt"
error () {
echo "$1" >&2
exit 3
}
+arch_error() {
+ configure_url="https://ci.inria.fr/ocaml/computer/${NODE_NAME}/configure"
+ msg="Unknown architecture. Make sure the OCAML_ARCH environemnt"
+ msg="$msg variable has been defined."
+ msg="$msg\nSee ${configure_url}"
+ error "$msg"
+}
+
+# Kill a task on Windows
+# Errors are ignored
+kill_task()
+{
+ task=$1
+ taskkill /f /im ${task} || true
+}
+
quote1 () {
printf "'%s'" "`printf %s "$1" | sed -e "s/'/'\\\\\\\\''/g"`";
}
set -x
#########################################################################
-# "Parse" mandatory command-line arguments.
-
-arch="$1"
-branch="$2"
-shift 2
+# Save the current directory (on cygwin, /etc/profile changes it)
+jenkinsdir="$(pwd)"
+echo jenkinsdir=${jenkinsdir}
#########################################################################
# If we are called from a Windows batch script, we must set up the
# Unix environment variables (e.g. PATH).
-case "$arch" in
+case "${OCAML_ARCH}" in
bsd|macos|linux) ;;
cygwin|mingw|mingw64)
. /etc/profile
. "$HOME/.profile"
. "$HOME/.msenv64"
;;
- *) error "unknown architecture: $arch";;
+ *) arch_error;;
esac
#########################################################################
# default values
make=make
instdir="$HOME/ocaml-tmp-install"
-docheckout=false
-makefile=Makefile
configure=unix
+confoptions="${OCAML_CONFIGURE_OPTIONS}"
+make_native=true
+cleanup=false
-case "$arch" in
- bsd)
- make=gmake
- workdir=.
- ;;
- macos)
- workdir=.
- ;;
+case "${OCAML_ARCH}" in
+ bsd) make=gmake ;;
+ macos) ;;
linux)
- workdir=.
+ confoptions="${confoptions} -with-instrumented-runtime"
;;
cygwin)
- workdir="$HOME/jenkins-workspace/$branch"
- docheckout=true
- ;;
+ cleanup=true;;
mingw)
- instdir=/cygdrive/c/ocamlmgw
- workdir="$HOME/jenkins-workspace/$branch"
- docheckout=true
- makefile=Makefile.nt
+ instdir='C:/ocamlmgw'
configure=nt
+ cleanup=true
;;
mingw64)
- instdir=/cygdrive/c/ocamlmgw64
- workdir="$HOME/jenkins-workspace/$branch"
- docheckout=true
- makefile=Makefile.nt
+ instdir='C:/ocamlmgw64'
configure=nt
+ cleanup=true
;;
msvc)
- instdir=/cygdrive/c/ocamlms
- workdir="$HOME/jenkins-workspace/$branch"
- docheckout=true
- makefile=Makefile.nt
+ instdir='C:/ocamlms'
configure=nt
+ cleanup=true
;;
msvc64)
- instdir=/cygdrive/c/ocamlms64
- workdir="$HOME/jenkins-workspace/$branch"
- docheckout=true
- makefile=Makefile.nt
+ instdir='C:/ocamlms64'
configure=nt
+ cleanup=true
;;
- *) error "unknown architecture: $arch";;
+ *) arch_error;;
esac
+# Make sure two builds won't use the same install directory
+instdir="$instdir-$$"
+
+#########################################################################
+# On Windows, cleanup processes that may remain from previous run
+
+if $cleanup; then
+ tasks="tee ocamlrun program"
+ for task in ${tasks}; do kill_task ${task}.exe; done
+fi
+
#########################################################################
# Go to the right directory
pwd
-cd "$workdir"
+cd "$jenkinsdir"
#########################################################################
# parse optional command-line arguments (has to be done after the "cd")
-# Configure options are not allowed to have spaces or special characters
-# for the moment. We'll fix that when needed.
-confoptions=""
+
while [ $# -gt 0 ]; do
case $1 in
-conf) confoptions="$confoptions `quote1 "$2"`"; shift;;
-patch1) patch -f -p1 <"$2"; shift;;
- -newmakefiles) makefile=Makefile;;
+ -no-native) make_native=false;;
*) error "unknown option $1";;
esac
shift
# Tell gcc to use only ASCII in its diagnostic outputs.
export LC_ALL=C
-$make -f $makefile distclean || :
+$make distclean || :
-if $docheckout; then
- git pull
-fi
+# `make distclean` does not clean the files from previous versions that
+# are not produced by the current version, so use `git clean` in addition.
+git clean -f -d -x
case $configure in
- unix) eval "./configure -prefix '$instdir' $confoptions";;
+ unix)
+ confoptions="$confoptions -with-debug-runtime"
+ if $flambda; then
+ confoptions="$confoptions -flambda"
+ fi
+ 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
+ cp config/Makefile.${OCAML_ARCH} config/Makefile
+ sed -i "s%PREFIX=\(.\+\)%PREFIX=${instdir}%" config/Makefile
+ sed -i 's%RUNTIMED=.\+%RUNTIMED=true%' config/Makefile
+ if $flambda; then
+ sed -i 's%FLAMBDA=.\+%FLAMBDA=true%' config/Makefile
+ fi
;;
*) error "internal error";;
esac
-$make -f $makefile world.opt
-$make -f $makefile install
+$make coldstart
+$make core
+$make coreboot
+$make world
+if $make_native; then
+ $make opt
+ $make opt.opt
+fi
+$make install
rm -rf "$instdir"
cd testsuite
| Texp_match (_, f1, f2, _) ->
bind_cases f1;
bind_cases f2
- | Texp_function (_, f, _)
+ | Texp_function { cases = f; }
| Texp_try (_, f) ->
bind_cases f
| _ -> ()
let arg_list = [
"-noloc", Arg.Clear print_locations, " : don't print source information";
"-reloc", Arg.Set print_reloc_info, " : print relocation information";
+ "-args", Arg.Expand Arg.read_arg,
+ "<file> Read additional newline separated command line arguments \n\
+ \ from <file>";
+ "-args0", Arg.Expand Arg.read_arg0,
+ "<file> Read additional NUL separated command line arguments from \n\
+ \ <file>";
]
let arg_usage =
Printf.sprintf "%s [OPTIONS] FILES : dump content of bytecode files"
printf "## end of ocaml dump of %S\n%!" filename
let main() =
- Arg.parse arg_list arg_fun arg_usage;
+ Arg.parse_expand arg_list arg_fun arg_usage;
exit 0
let _ = main ()
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Copyright 2016--2017 Edwin Török *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* Detects newly added symbols that are missing "@since" annotations,
+ or removed symbols that didn't have "@deprecated" annotation before.
+
+ Handles: values, exceptions.
+ Ignores: variants, record fields, classes, module aliasing or includes, ...
+ Out of scope: changes in arity, parameters, ...
+
+ Missing attributes on undocumented identifiers in undocumented modules
+ are not reported.
+
+ Use 'make lintapidiff' in the root directory to run
+*)
+open Location
+open Parsetree
+
+(* oldest Ocaml version that we show missing @since errors for *)
+let oldest = "4.00.0"
+
+(* do not check @since annotations for these *)
+let ignore_changes_for = [
+ "type Pervasives.format6" (* this used to be a built-in type *);
+ (* discarded by stop comments: *)
+ "type Unix.map_file_impl";
+ "value Unix.map_file_impl";
+]
+
+module IdMap = Map.Make(String)
+
+module Version : sig
+ type t
+ val oldest : t
+ val is_same : t -> t -> bool
+ val is_strictly_older: t -> than:t -> bool
+ val of_string_exn : string -> t
+ val pp : Format.formatter -> t -> unit
+end = struct
+ type t = int * int * int
+
+ let is_same a b = a = b
+ let is_strictly_older a ~than = a < than
+ let of_string_exn str =
+ try Scanf.sscanf str "%u.%u.%u" (fun a b c -> (a,b,c))
+ with _ -> Scanf.sscanf str "%u.%u" (fun a b -> (a,b,0))
+
+ let oldest = of_string_exn oldest
+ let pp ppf (major,minor,patch) =
+ Format.fprintf ppf "%u.%02u.%u" major minor patch
+end
+
+module Doc = struct
+ type t = {
+ since: Version.t option;
+ deprecated: bool;
+ loc: Location.t;
+ has_doc_parent: bool;
+ has_doc: bool;
+ }
+
+ let empty = {since = None; deprecated=false; loc=Location.none;
+ has_doc_parent=false;has_doc=false}
+
+ let since = Str.regexp "\\(.\\|\n\\)*@since +\\([^ ]+\\).*"
+
+ let find_attr lst attrs =
+ try Some (List.find (fun (loc, _) -> List.mem loc.txt lst) attrs)
+ with Not_found -> None
+
+ let get_doc lst attrs = match find_attr lst attrs with
+ | Some (_, PStr [{pstr_desc=Pstr_eval(
+ {pexp_desc=Pexp_constant(Pconst_string (doc, _));_}, _);_}])
+ when doc <> "/*" && doc <> "" -> Some doc
+ | _ -> None
+
+ let is_deprecated attrs =
+ find_attr ["ocaml.deprecated"; "deprecated"] attrs <> None ||
+ match get_doc ["ocaml.text"] attrs with (* for toplevel module annotation *)
+ | None -> false
+ | Some text ->
+ try Misc.search_substring "@deprecated" text 0 >= 0
+ with Not_found -> false
+
+ let get parent_info loc attrs =
+ let doc = get_doc ["ocaml.doc"; "ocaml.text"] attrs in
+ {
+ since = (match doc with
+ | Some doc ->
+ if Str.string_match since doc 0 then
+ Some (Str.matched_group 2 doc |> String.trim
+ |> Version.of_string_exn)
+ else parent_info.since
+ | None -> parent_info.since);
+ deprecated = parent_info.deprecated || is_deprecated attrs;
+ loc;
+ has_doc_parent = parent_info.has_doc_parent || parent_info.has_doc;
+ has_doc = doc <> None
+ }
+end
+
+module Ast = struct
+ let add_path ~f prefix path name attrs inherits map =
+ let path = Path.Pdot (path, name.txt, 0) in
+ let id = prefix ^ " " ^ (Printtyp.string_of_path path) in
+ (* inherits: annotation on parent is inherited by all children,
+ so it suffices to annotate just the new module, and not all its elements
+ *)
+ let info = f inherits name.loc attrs in
+ IdMap.add id info map
+
+ let rec add_item ~f path inherits map item =
+ let rec add_module_type path ty (inherits, map) =
+ let self = add_item ~f path inherits in
+ match ty.pmty_desc with
+ | Pmty_signature lst -> List.fold_left self map lst
+ | Pmty_functor ({txt;_}, _, m) ->
+ let path = Path.Papply(path, Path.Pident (Ident.create txt)) in
+ add_module_type path m (inherits, map)
+ | Pmty_ident _ | Pmty_with _ | Pmty_typeof _| Pmty_extension _
+ | Pmty_alias _ -> map
+ in
+ let enter_path path name ty attrs map =
+ let path = Path.Pdot (path, name.txt, 0) in
+ let inherits = f inherits name.loc attrs in
+ add_module_type path ty (inherits, map)
+ in
+ let add_module map m =
+ enter_path path m.pmd_name m.pmd_type m.pmd_attributes map
+ in
+ match item.psig_desc with
+ | Psig_value vd ->
+ add_path ~f "value" path vd.pval_name vd.pval_attributes inherits map
+ | Psig_type (_,lst) ->
+ List.fold_left (fun map t ->
+ add_path ~f "type" path t.ptype_name t.ptype_attributes inherits map
+ ) map lst
+ | Psig_exception e ->
+ add_path ~f "exception" path e.pext_name e.pext_attributes inherits map
+ | Psig_module m -> add_module map m
+ | Psig_recmodule lst -> List.fold_left add_module map lst
+ | Psig_modtype s ->
+ begin match s.pmtd_type with
+ | None -> map
+ | Some ty ->
+ enter_path path s.pmtd_name ty s.pmtd_attributes map
+ end
+ | Psig_typext _|Psig_open _|Psig_include _|Psig_class _|Psig_class_type _
+ | Psig_attribute _|Psig_extension _ -> map
+
+ let add_items ~f path (inherits,map) items =
+ (* module doc *)
+ let inherits = List.fold_left (fun inherits -> function
+ | {psig_desc=Psig_attribute a;_}
+ when (Doc.get_doc ["ocaml.doc";"ocaml.text"][a] <> None) ->
+ f inherits (Location.none) [a]
+ | _ -> inherits
+ ) inherits items in
+ List.fold_left (add_item ~f path inherits) map items
+
+ let parse_file ~orig ~f ~init input =
+ try
+ let id =
+ orig |> Filename.chop_extension |> Filename.basename |>
+ String.capitalize_ascii |> Ident.create in
+ let ast = Pparse.file ~tool_name:"lintapidiff" Format.err_formatter input
+ Parse.interface Pparse.Signature in
+ Location.input_name := orig;
+ add_items ~f (Path.Pident id) (init,IdMap.empty) ast
+ with e ->
+ Format.eprintf "%a@." Location.report_exception e;
+ raise e
+end
+
+module Git = struct
+ let with_show ~f rev path =
+ let obj = rev ^ ":" ^ path in
+ let suffix = Printf.sprintf "-%s:%s" rev (Filename.basename path) in
+ let tmp = Filename.temp_file "lintapidiff" suffix in
+ let cmd = Printf.sprintf "git show %s >%s 2>/dev/null"
+ (Filename.quote obj) (Filename.quote tmp) in
+ Misc.try_finally (fun () ->
+ match Sys.command cmd with
+ | 0 -> Ok (f tmp)
+ | 128 -> Error `Not_found
+ | r ->
+ Location.errorf ~loc:(in_file obj) "exited with code %d" r |>
+ Format.eprintf "%a@." Location.report_error;
+ Error `Exit)
+ (fun () -> Misc.remove_file tmp)
+end
+
+module Diff = struct
+ type seen_info = {
+ last_not_seen: Version.t option;
+ first_seen: Version.t;
+ deprecated: bool;
+ }
+
+ let err k (loc, msg, seen, latest) =
+ let info_seen ppf = function
+ | None ->
+ Format.fprintf ppf "%s was not seen in any analyzed version" k
+ | Some a ->
+ begin match a.last_not_seen with
+ | Some v ->
+ Format.fprintf ppf "%s was not seen in version %a" k Version.pp v
+ | None -> Format.fprintf ppf "%s was seen in all analyzed versions" k
+ end;
+ Format.fprintf ppf "@,%s was seen in version %a"
+ k Version.pp a.first_seen;
+ if a.deprecated then
+ Format.fprintf ppf "@,%s was marked as deprecated" k
+ in
+ let info_latest ppf = function
+ | None -> Format.fprintf ppf "%s was deleted in HEAD" k
+ | Some s ->
+ begin match s.Doc.since with
+ | Some v -> Format.fprintf ppf "%s has @since %a" k Version.pp v
+ | None -> Format.fprintf ppf "%s has no @since annotation" k
+ end;
+ if s.Doc.deprecated then
+ Format.fprintf ppf "@,%s is marked as deprecated" k
+ in
+ Location.errorf ~loc "@[%s %s@,%a@,%a@]" msg k
+ info_seen seen info_latest latest |>
+ Format.eprintf "%a@." Location.report_error
+
+ let parse_file_at_rev ~path (prev,accum) rev =
+ let merge _ a b = match a, b with
+ | Some a, Some b ->
+ Some { a with deprecated=b.deprecated }
+ | None, Some a -> Some { a with last_not_seen=prev }
+ | Some _, None -> None (* deleted *)
+ | None, None -> assert false
+ in
+ let first_seen = Version.of_string_exn rev in
+ let empty = {last_not_seen=None;first_seen;deprecated=false} in
+ let f = Ast.parse_file ~orig:path ~init:empty ~f:(fun _ _ attrs ->
+ { last_not_seen=None;first_seen; deprecated=Doc.is_deprecated attrs }) in
+ let map = match Git.with_show ~f rev path with
+ | Ok r -> r
+ | Error `Not_found -> IdMap.empty
+ | Error `Exit -> raise Exit in
+ Some first_seen, IdMap.merge merge accum map
+
+ let check_changes ~first ~last default k seen latest =
+ let is_old v = Version.is_strictly_older v ~than:Version.oldest ||
+ Version.is_same v first
+ in
+ if List.mem k ignore_changes_for then None (* ignored *)
+ else let open! Doc in
+ match (seen:seen_info option), latest with
+ | None, None -> assert false
+ | _, Some {has_doc_parent=false;has_doc=false;deprecated=false;_} ->
+ None (* undocumented *)
+ | Some {deprecated=true;_}, None -> None (* deleted deprecated *)
+ | Some _, None ->
+ Some (default, "deleted non-deprecated", seen, latest)
+ | _, Some {deprecated=true;since=None;_} -> None (* marked as deprecated *)
+ | None, Some {loc; since=None; _} ->
+ Some (loc, "missing @since for new", seen, latest)
+ | Some {first_seen;_}, Some {loc; since=None;_} ->
+ if is_old first_seen then None
+ else Some (loc, "missing @since", seen, latest)
+ | Some {first_seen;_}, Some {loc; since=Some s;_} ->
+ if Version.is_same first_seen s then None (* OK, @since matches *)
+ else Some (loc, "mismatched @since", seen, latest)
+ | None, Some {loc; since=Some s;_} ->
+ if Version.is_strictly_older s ~than:last ||
+ Version.is_same s last then
+ Some (loc, "too old @since for new", seen, latest)
+ else None
+
+ let file path tags =
+ let _,syms_vers = List.fold_left (parse_file_at_rev ~path)
+ (None,IdMap.empty) tags in
+ let current = Ast.parse_file ~orig:path ~f:Doc.get ~init:Doc.empty path in
+ let loc = Location.in_file path in
+ let first = List.hd tags |> Version.of_string_exn
+ and last = List.hd (List.rev tags) |> Version.of_string_exn in
+ IdMap.merge (check_changes ~first ~last loc) syms_vers current
+end
+
+let rec read_lines accum =
+ match input_line stdin with
+ | line -> read_lines (line :: accum)
+ | exception End_of_file -> accum
+
+let () =
+ let tags = Sys.argv |> Array.to_list |> List.tl in
+ if tags = [] then begin
+ Printf.eprintf "tags list is empty!\n";
+ exit 1;
+ end;
+ let paths = read_lines [] in
+ Printf.printf "Parsing\n%!";
+ let count = List.fold_left (fun count path ->
+ let problems = Diff.file path tags in
+ IdMap.iter Diff.err problems;
+ count + IdMap.cardinal problems
+ ) 0 paths in
+ Printf.printf "Found %d potential problems\n%!" count;
+ if count > 0 then exit 2
+++ /dev/null
-#**************************************************************************
-#* *
-#* 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. *
-#* *
-#**************************************************************************
-
-$1=="enum" {n=0; next; }
- {for (i = 1; i <= NF; i++) {printf("let op%s = %d\n", $i, n++);}}
# be used.
case $# in
- 0) version="`ocamlc -v | sed -n -e 's/.*version //p'`";;
- 1) version="`sed -e 1q $1`";;
+ 0) version="`ocamlc -v | tr -d '\r' | sed -n -e 's/.*version //p'`";;
+ 1) version="`sed -e 1q $1 | tr -d '\r'`";;
*) echo "usage: make-version-header.sh [version-file]" >&2
exit 2;;
esac
--- /dev/null
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Nicolas Ojeda Bar, LexiFi *)
+(* *)
+(* Copyright 2016 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 ident = ['a'-'z''A'-'Z''_']['a'-'z''A'-'Z''0'-'9''_']*
+let space = [' ''\n''\r''\t']*
+
+rule find_enum = parse
+| "enum" space (ident as id) space '{' { id, opnames lexbuf }
+| _ { find_enum lexbuf }
+
+and opnames = parse
+| space (ident as op) space ',' { op :: opnames lexbuf }
+| space ident space '}' { [] }
+
+{
+ let print_opnames = ref false
+ let print_opcodes = ref false
+
+ open Printf
+
+ let () =
+ let spec =
+ [
+ "-opnames", Arg.Set print_opnames, " Dump opcode names";
+ "-opcodes", Arg.Set print_opcodes, " Dump opcode numbers";
+ ]
+ in
+ Arg.parse (Arg.align spec) ignore "Extract opcode info from instruct.h";
+ let lexbuf = Lexing.from_channel stdin in
+ let id, opnames = find_enum lexbuf in
+ if !print_opnames then begin
+ printf "let names_of_%s = [|\n" id;
+ List.iter (fun s -> printf " %S;\n" s) opnames;
+ printf "|]\n"
+ end;
+ if !print_opcodes then
+ List.iteri (fun i op -> printf "let op%s = %i\n" op i) opnames
+}
open Config
open Cmo_format
+(* Command line option to prevent printing approximation and function code *)
+let no_approx = ref false
+let no_code = ref false
+
let input_stringlist ic len =
let get_string_list sect len =
let rec fold s e acc =
printf "Implementations imported:\n";
List.iter print_name_crc cmx
+let print_global_table table =
+ printf "Globals defined:\n";
+ Tbl.iter
+ (fun id _ -> print_line (Ident.name id))
+ table.num_tbl
+
open Cmx_format
let print_cmx_infos (ui, crc) =
ui.ui_name crc ui.ui_defines ui.ui_imports_cmi ui.ui_imports_cmx;
begin match ui.ui_export_info with
| Clambda approx ->
- printf "Approximation:\n";
- Format.fprintf Format.std_formatter " %a@." Printclambda.approx approx
+ if not !no_approx then begin
+ printf "Clambda approximation:\n";
+ Format.fprintf Format.std_formatter " %a@." Printclambda.approx approx
+ end else
+ Format.printf "Clambda unit@.";
| Flambda export ->
- printf "Flambda export information:\n";
- let cu =
- Compilation_unit.create (Ident.create_persistent ui.ui_name)
- (Linkage_name.create "__dummy__")
- in
- Compilation_unit.set_current cu;
- Format.printf " %a\n" Export_info.print_all export
+ if not !no_approx || not !no_code then
+ printf "Flambda export information:\n"
+ else
+ printf "Flambda unit\n";
+ if not !no_approx then begin
+ let cu =
+ Compilation_unit.create (Ident.create_persistent ui.ui_name)
+ (Linkage_name.create "__dummy__")
+ in
+ Compilation_unit.set_current cu;
+ let root_symbols =
+ List.map (fun s ->
+ Symbol.unsafe_create cu (Linkage_name.create ("caml"^s)))
+ ui.ui_defines
+ in
+ Format.printf "approximations@ %a@.@."
+ Export_info.print_approx (export, root_symbols)
+ end;
+ if not !no_code then
+ Format.printf "functions@ %a@.@."
+ Export_info.print_functions export
end;
let pr_funs _ fns =
List.iter (fun arity -> printf " %d" arity) fns in
"Primitives used"
print_line
(input_stringlist ic len)
+ | "SYMB" ->
+ print_global_table (input_value ic)
| _ -> ()
with _ -> ()
)
end
end
-let arg_list = []
+let arg_list = [
+ "-no-approx", Arg.Set no_approx, " Do not print module approximation information";
+ "-no-code", Arg.Set no_code, " Do not print code from exported flambda functions";
+ "-args", Arg.Expand Arg.read_arg,
+ "<file> Read additional newline separated command line arguments \n\
+ \ from <file>";
+ "-args0", Arg.Expand Arg.read_arg0,
+ "<file> Read additional NUL separated command line arguments from \n\
+ \ <file>";
+]
let arg_usage =
Printf.sprintf "%s [OPTIONS] FILES : give information on files" Sys.argv.(0)
let main() =
- Arg.parse arg_list dump_obj arg_usage;
+ Arg.parse_expand arg_list dump_obj arg_usage;
exit 0
let _ = main ()
/**************************************************************************/
#include "../config/s.h"
-#include "../byterun/caml/mlvalues.h"
-#include "../byterun/caml/alloc.h"
#include <stdio.h>
#ifdef HAS_LIBBFD
let _dflambda = option "-dflambda"
let _dinstr = option "-dinstr"
let _dtimings = option "-dtimings"
+ let _args = Arg.read_arg
+ let _args0 = Arg.read_arg0
let anonymous = process_file
end);;
:: ("-p", Arg.String add_profarg, "[afilmt] Same as option -P")
:: Options.list
in
-Arg.parse optlist process_file usage;
+Arg.parse_expand optlist process_file usage;
if !with_impl && !with_intf then begin
fprintf stderr "ocamlcp cannot deal with both \"-impl\" and \"-intf\"\n";
fprintf stderr "please compile interfaces and implementations separately\n";
let bound_vars =
List.fold_left
(fun bv modname ->
- Depend.open_module bv (Longident.Lident modname))
+ Depend.open_module bv (Longident.parse modname))
!module_map ((* PR#7248 *) List.rev !Clflags.open_modules)
in
let r = extract_function bound_vars ast in
Clflags.classic := false;
add_to_list first_include_dirs Filename.current_dir_name;
Compenv.readenv ppf Before_args;
- Arg.parse [
+ Clflags.add_arguments __LOC__ [
"-absname", Arg.Set Location.absname,
" Show absolute filenames in error messages";
"-all", Arg.Set all_dependencies,
" Output one line per file, regardless of the length";
"-open", Arg.String (add_to_list Clflags.open_modules),
"<module> Opens the module <module> before typing";
+ "-plugin", Arg.String Compplugin.load,
+ "<plugin> Load dynamic plugin <plugin>";
"-pp", Arg.String(fun s -> Clflags.preprocessor := Some s),
"<cmd> Pipe sources through preprocessor <cmd>";
"-ppx", Arg.String (add_to_list first_ppx),
" Print version and exit";
"-vnum", Arg.Unit print_version_num,
" Print version number and exit";
- ] file_dependencies usage;
+ "-args", Arg.Expand Arg.read_arg,
+ "<file> Read additional newline separated command line arguments \n\
+ \ from <file>";
+ "-args0", Arg.Expand Arg.read_arg0,
+ "<file> Read additional NUL separated command line arguments from \n\
+ \ <file>"
+ ];
+ Clflags.parse_arguments file_dependencies usage;
Compenv.readenv ppf Before_link;
if !sort_files then sort_files_by_dependencies !files
else List.iter print_file_dependencies (List.sort compare !files);
in Bytes.to_string (aux 0)
| _ -> s
+let flexdll_dirs =
+ let dirs =
+ let expand = Misc.expand_directory Config.standard_library in
+ List.map expand Config.flexdll_dirs
+ in
+ let f dir =
+ let dir =
+ if String.contains dir ' ' then
+ "\"" ^ dir ^ "\""
+ else
+ dir
+ in
+ "-L" ^ dir
+ in
+ List.map f dirs
+
let build_libs () =
if !c_objs <> [] then begin
if !dynlink then begin
let retcode = command
- (Printf.sprintf "%s %s -o %s %s %s %s %s %s"
+ (Printf.sprintf "%s %s -o %s %s %s %s %s %s %s"
Config.mkdll
(if !debug then "-g" else "")
(prepostfix "dll" !output_c Config.ext_dll)
(String.concat " " !ld_opts)
(make_rpath mksharedlibrpath)
(String.concat " " !c_libs)
+ (String.concat " " flexdll_dirs)
)
in
if retcode <> 0 then if !failsafe then dynlink := false else exit 2
module Options = Main_args.Make_optcomp_options (struct
let _a () = make_archive := true; option "-a" ()
let _absname = option "-absname"
+ let _afl_instrument = option "-afl-instrument"
+ let _afl_inst_ratio n = option_with_int "-afl-inst-ratio" n
let _annot = option "-annot"
let _binannot = option "-bin-annot"
let _c = option "-c"
let _dtimings = option "-dtimings"
let _opaque = option "-opaque"
+ let _args = Arg.read_arg
+ let _args0 = Arg.read_arg0
let anonymous = process_file
end);;
\032 t try ... with")
:: Options.list
in
-Arg.parse optlist process_file usage;
+Arg.parse_expand optlist process_file usage;
if !with_impl && !with_intf then begin
fprintf stderr "ocamloptp cannot deal with both \"-impl\" and \"-intf\"\n";
fprintf stderr "please compile interfaces and implementations separately\n";
let main () =
try
Warnings.parse_options false "a";
- Arg.parse [
+ Arg.parse_expand [
"-f", Arg.String (fun s -> dumpfile := s),
"<file> Use <file> as dump file (default ocamlprof.dump)";
"-F", Arg.String (fun s -> special_id := s),
" Print version and exit";
"-vnum", Arg.Unit print_version_num,
" Print version number and exit";
- ] process_anon_file usage;
+ "-args", Arg.Expand Arg.read_arg,
+ "<file> Read additional newline separated command line arguments \n\
+ \ from <file>";
+ "-args0", Arg.Expand Arg.read_arg0,
+ "<file> Read additional NUL separated command line arguments from \n\
+ \ <file>"
+ ] process_anon_file usage;
exit 0
with
| Profiler msg ->
| x -> close_in ic; raise x
let main() =
- Arg.parse
+ Arg.parse_expand
["-used", Arg.Unit(fun () -> used := true; defined := false),
"show primitives referenced in the object files";
"-defined", Arg.Unit(fun () -> defined := true; used := false),
"-all", Arg.Unit(fun () -> defined := true; used := true),
"show primitives defined or referenced in the object files";
"-exclude", Arg.String(fun s -> exclude_file := s),
- "<file> don't print the primitives mentioned in <file>"]
+ "<file> don't print the primitives mentioned in <file>";
+ "-args", Arg.Expand Arg.read_arg,
+ "<file> Read additional newline separated command line arguments \n\
+ \ from <file>";
+ "-args0", Arg.Expand Arg.read_arg0,
+ "<file> Read additional NUL separated command line arguments from \n\
+ \ <file>";]
scan_obj
"Usage: primreq [options] <.cmo and .cma files>\nOptions are:";
if String.length !exclude_file > 0 then exclude !exclude_file;
"-src", Arg.Set gen_ml,
" : convert .cmt or .cmti back to source code (without comments)";
"-info", Arg.Set print_info_arg, " : print information on the file";
+ "-args", Arg.Expand Arg.read_arg,
+ " <file> Read additional newline separated command line arguments \n\
+ \ from <file>";
+ "-args0", Arg.Expand Arg.read_arg0,
+ "<file> Read additional NUL separated command line arguments from \n\
+ \ <file>";
]
let arg_usage =
let _ =
Clflags.annotations := true;
- Arg.parse arg_list (fun filename ->
+ Arg.parse_expand arg_list (fun filename ->
if
Filename.check_suffix filename ".cmt" ||
Filename.check_suffix filename ".cmti"
(fun x -> Oval_int64 (O.obj x : int64)) ))
] : (Path.t * printer) list)
- let exn_printer ppf path =
- fprintf ppf "<printer %a raised an exception>" Printtyp.path path
+ let exn_printer ppf path exn =
+ fprintf ppf "<printer %a raised an exception: %s>" Printtyp.path path (Printexc.to_string exn)
- let out_exn path =
- Oval_printer (fun ppf -> exn_printer ppf path)
+ let out_exn path exn =
+ Oval_printer (fun ppf -> exn_printer ppf path exn)
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 exn in
let printer obj = Oval_printer (fun ppf -> print_val ppf obj) in
printers := (path, Simple (ty, printer)) :: !printers
| Zero fn ->
let out_printer obj =
let printer ppf =
- try fn ppf obj with _ -> exn_printer ppf function_path in
+ try fn ppf obj with exn -> exn_printer ppf function_path exn in
Oval_printer printer in
Zero out_printer
| Succ fn ->
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 exn -> (fun _obj -> out_exn path exn) end
| _ -> find remainder end in
find !printers
and apply_generic_printer path printer args =
match (printer, args) with
- | (Zero fn, []) -> (fun (obj : O.t)-> try fn obj with _ -> out_exn path)
+ | (Zero fn, []) -> (fun (obj : O.t)-> try fn obj with exn -> out_exn path exn)
| (Succ fn, arg :: args) ->
let printer = fn (fun depth obj -> tree_of_val depth obj arg) in
apply_generic_printer path printer args
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=slam ; main_module_block_size=size;
module_ident; required_globals }
else
Asmgen.compile_implementation_flambda ~source_provenance:Timings.Toplevel
~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");
+ ~module_ident ~module_initializer:slam ~filename:"toplevel");
Asmlink.call_linker_shared [fn ^ ext_obj] dll;
Sys.remove (fn ^ ext_obj);
let preload_objects = ref []
+(* Position of the first non expanded argument *)
+let first_nonexpanded_pos = ref 0
+
+let current = ref (!Arg.current)
+
+let argv = ref Sys.argv
+
+(* Test whether the option is part of a responsefile *)
+let is_expanded pos = pos < !first_nonexpanded_pos
+
+let expand_position pos len =
+ if pos < !first_nonexpanded_pos then
+ first_nonexpanded_pos := !first_nonexpanded_pos + len (* Shift the position *)
+ else
+ first_nonexpanded_pos := pos + len + 2 (* New last position *)
+
+
let prepare ppf =
Opttoploop.set_paths ();
try
|| Filename.check_suffix name ".cmx"
|| Filename.check_suffix name ".cmxa"
then preload_objects := name :: !preload_objects
- else
- begin
- let newargs = Array.sub Sys.argv !Arg.current
- (Array.length Sys.argv - !Arg.current)
+ else if is_expanded !current then begin
+ (* Script files are not allowed in expand options because otherwise the
+ check in override arguments may fail since the new argv can be larger
+ than the original argv.
+ *)
+ Printf.eprintf "For implementation reasons, the toplevel does not support\
+ \ having script files (here %S) inside expanded arguments passed through the\
+ \ -args{,0} command-line option.\n" name;
+ exit 2
+ end else begin
+ let newargs = Array.sub !argv !Arg.current
+ (Array.length !argv - !Arg.current)
in
if prepare ppf && Opttoploop.run_script ppf name newargs
then exit 0
exit 0;
;;
+let wrap_expand f s =
+ let start = !current in
+ let arr = f s in
+ expand_position start (Array.length arr);
+ arr
+
module Options = Main_args.Make_opttop_options (struct
let set r () = r := true
let clear r () = r := false
let _open s = open_modules := s :: !open_modules
let _plugin p = Compplugin.load p
+ let _args = wrap_expand Arg.read_arg
+ let _args0 = wrap_expand Arg.read_arg0
+
let anonymous = file_argument
end);;
let main () =
native_code := true;
- Arg.parse Options.list file_argument usage;
+ let list = ref Options.list in
+ begin
+ try
+ Arg.parse_and_expand_argv_dynamic current argv list file_argument usage;
+ with
+ | Arg.Bad msg -> Format.fprintf Format.err_formatter "%s%!" msg; exit 2
+ | Arg.Help msg -> Format.fprintf Format.std_formatter "%s%!" msg; exit 0
+ end;
if not (prepare Format.err_formatter) then exit 2;
Opttoploop.loop Format.std_formatter
let preload_objects = ref []
+(* Position of the first non expanded argument *)
+let first_nonexpanded_pos = ref 0
+
+let current = ref (!Arg.current)
+
+let argv = ref Sys.argv
+
+(* Test whether the option is part of a responsefile *)
+let is_expanded pos = pos < !first_nonexpanded_pos
+
+let expand_position pos len =
+ if pos < !first_nonexpanded_pos then
+ first_nonexpanded_pos := !first_nonexpanded_pos + len (* Shift the position *)
+ else
+ first_nonexpanded_pos := pos + len + 2 (* New last position *)
+
let prepare ppf =
Toploop.set_paths ();
try
let ppf = Format.err_formatter in
if Filename.check_suffix name ".cmo" || Filename.check_suffix name ".cma"
then preload_objects := name :: !preload_objects
- else
- begin
- let newargs = Array.sub Sys.argv !Arg.current
- (Array.length Sys.argv - !Arg.current)
+ else if is_expanded !current then begin
+ (* Script files are not allowed in expand options because otherwise the
+ check in override arguments may fail since the new argv can be larger
+ than the original argv.
+ *)
+ Printf.eprintf "For implementation reasons, the toplevel does not support\
+ \ having script files (here %S) inside expanded arguments passed through the\
+ \ -args{,0} command-line option.\n" name;
+ exit 2
+ end else begin
+ let newargs = Array.sub !argv !current
+ (Array.length !argv - !current)
in
Compenv.readenv ppf Before_link;
if prepare ppf && Toploop.run_script ppf name newargs
exit 0;
;;
+let wrap_expand f s =
+ let start = !current in
+ let arr = f s in
+ expand_position start (Array.length arr);
+ arr
+
module Options = Main_args.Make_bytetop_options (struct
let set r () = r := true
let clear r () = r := false
let _dtimings = set print_timings
let _dinstr = set dump_instr
+ let _args = wrap_expand Arg.read_arg
+ let _args0 = wrap_expand Arg.read_arg0
+
let anonymous s = file_argument s
end);;
let main () =
let ppf = Format.err_formatter in
Compenv.readenv ppf Before_args;
- Arg.parse Options.list file_argument usage;
+ let list = ref Options.list in
+ begin
+ try
+ Arg.parse_and_expand_argv_dynamic current argv list file_argument usage;
+ with
+ | Arg.Bad msg -> Printf.eprintf "%s" msg; exit 2
+ | Arg.Help msg -> Printf.printf "%s" msg; exit 0
+ end;
Compenv.readenv ppf Before_link;
if not (prepare ppf) then exit 2;
Toploop.loop Format.std_formatter
--- /dev/null
+The implementation of the OCaml typechecker is complex. Modifying it
+will need a good understanding of the OCaml type system and type
+inference. Here is a reading list to ease your discovery of the
+typechecker:
+
+http://caml.inria.fr/pub/docs/u3-ocaml/index.html[Using, Understanding, and Unraveling the OCaml Language by Didier Rémy] ::
+This book provides (among other things) a formal description of parts
+of the core OCaml language, starting with a simple Core ML.
+
+http://okmij.org/ftp/ML/generalization.html[Efficient and Insightful Generalization by Oleg Kiselyov] ::
+This article describes the basis of the type inference algorithm used
+by the OCaml type checker. It is a recommended read if you want to
+understand the type-checker codebase, in particular its handling of
+polymorphism/generalization.
+
+After that, it is best to dive right in. There is no real "entry
+point", but an understanding of both the parsetree and the typedtree
+is necessary.
+
+The datastructures ::
+link:types.mli[Types] and link:typedtree.mli[Typedtree]
+are the two main datastructures in the typechecker. They correspond to
+the source code annotated with all the information needed for type
+checking and type inference. link:env.mli[Env] contains all the
+environments that are used in the typechecker. Each node in the
+typedtree is annotated with the local environment in which it was
+type-checked.
+
+Core utilities ::
+link:btype.mli[Btype] and link:ctype.mli[Ctype] contain
+the various low-level function needed for typing, in particular
+related to levels, unification and
+backtracking. link:mtype.mli[Mtype] contains utilities related
+to modules.
+
+Inference and checking::
+The `Type..` modules are related to inference and typechecking, each
+for a different part of the language:
+link:typetexp.mli[Typetexp] for type expressions,
+link:typecore.mli[Typecore] for the core language,
+link:typemod.mli[Typemod] for modules,
+link:typedecl.mli[Typedecl] for type declarations and finally
+link:typeclass.mli[Typeclass] for the object system.
+
+Inclusion/Module subtyping::
+Handling of inclusion relations are separated in the `Include...`
+modules: link:includecore.ml[Includecore] for the type and
+value declarations, link:includemod.mli[Includemod] for modules
+and finally link:includeclass.mli[Includeclass] for the object
+system.
+
+Dependencies between modules::
+Most of the modules presented above are inter-dependent. Since OCaml
+does not permit circular dependencies between files, the
+implementation uses forward declarations, implemented with references
+to functions that are filled later on. An example can be seen in
+link:typecore.ml[Typecore.type_module], which is filled in
+link:typemod.ml[Typemod].
let is_Tvar = function {desc=Tvar _} -> true | _ -> false
let is_Tunivar = function {desc=Tunivar _} -> true | _ -> false
+let is_Tconstr = function {desc=Tconstr _} -> true | _ -> false
let dummy_method = "*dummy method*"
let default_mty = function
(**** Utilities for fixed row private types ****)
-let has_constr_row t =
+let row_of_type t =
match (repr t).desc with
Tobject(t,_) ->
- let rec check_row t =
- match (repr t).desc with
- Tfield(_,_,_,t) -> check_row t
- | Tconstr _ -> true
- | _ -> false
- in check_row t
+ let rec get_row t =
+ let t = repr t in
+ match t.desc with
+ Tfield(_,_,_,t) -> get_row t
+ | _ -> t
+ in get_row t
| Tvariant row ->
- (match row_more row with {desc=Tconstr _} -> true | _ -> false)
+ row_more row
| _ ->
- false
+ t
+
+let has_constr_row t =
+ not (is_Tconstr t) && is_Tconstr (row_of_type t)
let is_row_name s =
let l = String.length s in
if l < 4 then false else String.sub s (l-4) 4 = "#row"
-let is_constr_row t =
+let is_constr_row ~allow_ident t =
match t.desc with
- Tconstr (Path.Pident id, _, _) -> is_row_name (Ident.name id)
+ Tconstr (Path.Pident id, _, _) when allow_ident ->
+ is_row_name (Ident.name id)
| Tconstr (Path.Pdot (_, s, _), _, _) -> is_row_name s
| _ -> false
val is_Tvar: type_expr -> bool
val is_Tunivar: type_expr -> bool
+val is_Tconstr: type_expr -> bool
val dummy_method: label
val default_mty: module_type option -> module_type
or a row variable *)
(**** Utilities for private abbreviations with fixed rows ****)
+val row_of_type: type_expr -> type_expr
val has_constr_row: type_expr -> bool
val is_row_name: string -> bool
-val is_constr_row: type_expr -> bool
+val is_constr_row: allow_ident:bool -> type_expr -> bool
(**** Utilities for type traversal ****)
if vd1.Types.val_loc <> vd2.Types.val_loc then
value_deps := (vd1, vd2) :: !value_deps
-let save_cmt filename modname binary_annots sourcefile initial_env sg =
+let save_cmt filename modname binary_annots sourcefile initial_env cmi =
if !Clflags.binary_annotations && not !Clflags.print_types then begin
- let imports = Env.imports () in
- let flags =
- List.concat [
- if !Clflags.recursive_types then [Cmi_format.Rectypes] else [];
- if !Clflags.opaque then [Cmi_format.Opaque] else [];
- ]
- in
let oc = open_out_bin filename in
let this_crc =
- match sg with
- None -> None
- | Some (sg) ->
- let cmi = {
- cmi_name = modname;
- cmi_sign = sg;
- cmi_flags = flags;
- cmi_crcs = imports;
- } in
- Some (output_cmi filename oc cmi)
+ match cmi with
+ | None -> None
+ | Some cmi -> Some (output_cmi filename oc cmi)
in
let source_digest = Misc.may_map Digest.file sourcefile in
let cmt = {
cmt_source_digest = source_digest;
cmt_initial_env = if need_to_clear_env then
keep_only_summary initial_env else initial_env;
- cmt_imports = List.sort compare imports;
+ cmt_imports = List.sort compare (Env.imports ());
cmt_interface_digest = this_crc;
cmt_use_summaries = need_to_clear_env;
} in
val read_cmt : string -> cmt_infos
val read_cmi : string -> Cmi_format.cmi_infos
-(** [save_cmt modname filename binary_annots sourcefile initial_env sg]
+(** [save_cmt filename modname binary_annots sourcefile initial_env cmi]
writes a cmt(i) file. *)
val save_cmt :
string -> (* filename.cmt to generate *)
binary_annots ->
string option -> (* source file *)
Env.t -> (* initial env *)
- Types.signature option -> (* if a .cmi was generated,
- the signature saved there *)
+ Cmi_format.cmi_infos option -> (* if a .cmi was generated *)
unit
(* Miscellaneous functions *)
try
begin match (d1, d2) with
(Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when l1 = l2 ||
- !Clflags.classic && not (is_optional l1 || is_optional l2) ->
+ (!Clflags.classic || !umode = Pattern) &&
+ not (is_optional l1 || is_optional l2) ->
unify env t1 t2; unify env u1 u2;
begin match commu_repr c1, commu_repr c2 with
Clink r, c2 -> set_commu r c2
raise (Unify [])
| _ when static_row row1 -> ()
| _ when may_inst ->
- let ext = newgenty (Tvariant {row2 with row_fields = r2}) in
+ let ext =
+ newgenty (Tvariant {row2 with row_fields = r2; row_name = None})
+ in
moregen_occur env rm1.level ext;
link_type rm1 ext
| Tconstr _, Tconstr _ ->
let ty = repr ty in
if not (TypeSet.mem ty !visited) then begin
visited := TypeSet.add ty !visited;
- begin match ty.desc with
+ let tm = row_of_type ty in
+ begin if not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm then
+ match tm.desc with (* PR#7348 *)
+ Tconstr (Path.Pdot(m,i,pos), tl, _abbrev) ->
+ let i' = String.sub i 0 (String.length i - 4) in
+ log_type ty;
+ ty.desc <- Tconstr(Path.Pdot(m,i',pos), tl, ref Mnil)
+ | _ -> assert false
+ else match ty.desc with
| Tvariant row ->
let row = row_repr row in
let fields = List.map
(* Forward declarations *)
let components_of_module' =
- ref ((fun ~deprecated:_ ~loc:__env _sub _path _mty -> assert false) :
+ 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 (pl, sub) = prefix_idents root 0 sub sg in
pl, sub, lazy (subst_signature sub sg)
-let set_nongen_level sub 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
- if sub = set_nongen_level Subst.identity root then
+ if sub = Subst.identity then
let sgs =
try
Hashtbl.find prefixed_sg root
(* fcomp_arg and fcomp_res must be prefixed eagerly, because
they are interpreted in the outer environment *)
fcomp_arg = may_map (Subst.modtype sub) ty_arg;
- fcomp_res = Subst.modtype (set_nongen_level sub path) ty_res;
+ fcomp_res = Subst.modtype sub ty_res;
fcomp_cache = Hashtbl.create 17;
fcomp_subst_cache = Hashtbl.create 17 }
| Mty_ident _
ps_flags = cmi.cmi_flags;
} in
save_pers_struct crc ps;
- sg
+ cmi
with exn ->
close_out oc;
remove_file filename;
val read_signature: string -> string -> signature
(* Arguments: module name, file name. Results: signature. *)
val save_signature:
- deprecated:string option -> signature -> string -> string -> signature
+ deprecated:string option -> signature -> string -> string -> Cmi_format.cmi_infos
(* Arguments: signature, module name, file name. *)
val save_signature_with_imports:
deprecated:string option ->
signature -> string -> string -> (string * Digest.t option) list
- -> signature
+ -> Cmi_format.cmi_infos
(* Arguments: signature, module name, file name,
imported units with their CRCs. *)
(* PathSet.iter (fun p -> Format.eprintf "%a@ " Printtyp.path p) excl;
Format.eprintf "@."; *)
remove_aliases env excl sg
+
+
+(* Lower non-generalizable type variables *)
+
+let lower_nongen nglev mty =
+ let open Btype in
+ let it_type_expr it ty =
+ let ty = repr ty in
+ match ty with
+ {desc=Tvar _; level} ->
+ if level < generic_level && level > nglev then set_level ty nglev
+ | _ ->
+ type_iterators.it_type_expr it ty
+ in
+ let it = {type_iterators with it_type_expr} in
+ it.it_module_type it mty;
+ it.it_module_type unmark_iterators mty
val type_paths: Env.t -> Path.t -> module_type -> Path.t list
val contains_type: Env.t -> module_type -> bool
val remove_aliases: Env.t -> module_type -> module_type
+val lower_nongen: int -> module_type -> unit
Ovar_fields fields ->
print_list print_row_field (fun ppf -> fprintf ppf "@;<1 -2>| ")
ppf fields
- | Ovar_name (id, tyl) ->
- fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id
+ | Ovar_typ typ ->
+ print_simple_out_type ppf typ
in
fprintf ppf "%s[%s@[<hv>@[<hv>%a@]%a ]@]" (if non_gen then "_" else "")
(if closed then if tags = None then " " else "< "
and out_variant =
| Ovar_fields of (string * bool * out_type list) list
- | Ovar_name of out_ident * out_type list
+ | Ovar_typ of out_type
type out_class_type =
| Octy_constr of out_ident * out_type list
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
(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
+ begin match filtered_lvs with
+ | [] -> fprintf ppf "_"
+ | (_, lbl, _) :: q ->
+ let elision_mark ppf =
+ (* we assume that there is no label repetitions here *)
+ if Array.length lbl.lbl_all > 1 + List.length q then
+ fprintf ppf ";@ _@ "
+ else () in
+ fprintf ppf "@[{%a%t}@]"
+ pretty_lvals filtered_lvs elision_mark
+ end
| Tpat_array vs ->
fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs
| Tpat_lazy v ->
| ({pat_desc = Tpat_record(_)},_) :: _ -> true
| ({pat_desc = Tpat_array(_)},_) :: _ -> false
| ({pat_desc = Tpat_lazy(_)},_) :: _ -> true
-| _ -> fatal_error "Parmatch.full_match"
+| ({pat_desc = (Tpat_any|Tpat_var _|Tpat_alias _|Tpat_or _)},_) :: _
+| []
+ ->
+ assert false
+(* Written as a non-fragile matching, PR7451 originated from a fragile matching below. *)
let should_extend ext env = match ext with
| None -> false
-| Some ext -> match env with
- | ({pat_desc =
- Tpat_construct(_, {cstr_tag=(Cstr_constant _|Cstr_block _)},_)}
- as p, _) :: _ ->
- let path = get_type_path p.pat_type p.pat_env in
- Path.same path ext
- | _ -> false
+| Some ext -> begin match env with
+ | [] -> assert false
+ | (p,_)::_ ->
+ begin match p.pat_desc with
+ | Tpat_construct
+ (_, {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)},_) ->
+ let path = get_type_path p.pat_type p.pat_env in
+ Path.same path ext
+ | Tpat_construct
+ (_, {cstr_tag=(Cstr_extension _)},_) -> false
+ | Tpat_constant _|Tpat_tuple _|Tpat_variant _
+ | Tpat_record _|Tpat_array _ | Tpat_lazy _
+ -> false
+ | Tpat_any|Tpat_var _|Tpat_alias _|Tpat_or _
+ -> assert false
+ end
+end
(* complement constructor tags *)
let complete_tags nconsts nconstrs tags =
let pr_typ () =
match ty.desc with
| Tvar _ ->
+ (*let lev =
+ if is_non_gen sch ty then "/" ^ string_of_int ty.level else "" in*)
Otyp_var (is_non_gen sch ty, name_of_type ty)
| Tarrow(l, ty1, ty2, _) ->
let pr_arrow l ty1 ty2 =
let (p', s) = best_type_path p in
let id = tree_of_path p' in
let args = tree_of_typlist sch (apply_subst s tyl) in
+ let out_variant =
+ if is_nth s then List.hd args else Otyp_constr (id, args) in
if row.row_closed && all_present then
- if is_nth s then List.hd args else Otyp_constr (id, args)
+ out_variant
else
let non_gen = is_non_gen sch px in
let tags =
if all_present then None else Some (List.map fst present) in
- let inh =
- match args with
- [Otyp_constr (i, a)] when is_nth s -> Ovar_name (i, a)
- | _ ->
- (* fallback case, should change outcometree... *)
- Ovar_name (tree_of_path p, tree_of_typlist sch tyl)
- in
- Otyp_variant (non_gen, inh, row.row_closed, tags)
+ Otyp_variant (non_gen, Ovar_typ out_variant, row.row_closed, tags)
| _ ->
let non_gen =
not (row.row_closed && all_present) && is_non_gen sch px in
[]
| (t1, t1') :: (t2, t2') :: rem ->
let rem' = filter_trace keep_last rem in
- if is_constr_row t1' || is_constr_row t2'
+ if is_constr_row ~allow_ident:true t1'
+ || is_constr_row ~allow_ident:true t2'
|| same_path t1 t1' && same_path t2 t2' && not (keep_last && rem' = [])
then rem'
else (t1, t1') :: (t2, t2') :: rem'
line i ppf "Texp_let %a\n" fmt_rec_flag rf;
list i value_binding ppf l;
expression i ppf e;
- | Texp_function (p, l, _partial) ->
+ | Texp_function { arg_label = p; param = _; cases; partial = _; } ->
line i ppf "Texp_function\n";
arg_label i ppf p;
- list i case ppf l;
+ list i case ppf cases;
| Texp_apply (e, l) ->
line i ppf "Texp_apply\n";
expression i ppf e;
{ types: (Ident.t, Path.t) Tbl.t;
modules: (Ident.t, Path.t) Tbl.t;
modtypes: (Ident.t, module_type) Tbl.t;
- for_saving: bool;
- nongen_level: int }
+ for_saving: bool }
let identity =
{ types = Tbl.empty; modules = Tbl.empty; modtypes = Tbl.empty;
- for_saving = false; nongen_level = generic_level }
+ for_saving = false }
let add_type id p s = { s with types = Tbl.add id p s.types }
let for_saving s = { s with for_saving = true }
-let set_nongen_level s lev = { s with nongen_level = lev }
-
let loc s x =
if s.for_saving && not !Clflags.keep_locs then Location.none else x
else newty2 ty.level desc
in
save_desc ty desc; ty.desc <- Tsubst ty'; ty'
- else begin (* when adding a module to the environment *)
- if ty.level < generic_level then
- ty.level <- min ty.level s.nongen_level;
- ty
- end
+ else ty
| Tsubst ty ->
ty
| Tfield (m, k, _t1, _t2) when not s.for_saving && m = dummy_method
| _ ->
let desc = ty.desc in
save_desc ty desc;
+ let tm = row_of_type ty in
+ let has_fixed_row =
+ not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm in
(* Make a stub *)
let ty' = if s.for_saving then newpersty (Tvar None) else newgenvar () in
ty.desc <- Tsubst ty';
ty'.desc <-
- begin match desc with
+ begin if has_fixed_row then
+ match tm.desc with (* PR#7348 *)
+ Tconstr (Pdot(m,i,pos), tl, _abbrev) ->
+ let i' = String.sub i 0 (String.length i - 4) in
+ Tconstr(type_path s (Pdot(m,i',pos)), tl, ref Mnil)
+ | _ -> assert false
+ else match desc with
| Tconstr(p, tl, _abbrev) ->
Tconstr(type_path s p, List.map (typexp s) tl, ref Mnil)
| Tpackage(p, n, tl) ->
{ types = merge_tbls (type_path s2) s1.types s2.types;
modules = merge_tbls (module_path s2) s1.modules s2.modules;
modtypes = merge_tbls (modtype s2) s1.modtypes s2.modtypes;
- for_saving = s1.for_saving || s2.for_saving;
- nongen_level = min s1.nongen_level s2.nongen_level }
+ for_saving = s1.for_saving || s2.for_saving }
val add_type: Ident.t -> Path.t -> t -> t
val add_module: Ident.t -> Path.t -> t -> t
val add_modtype: Ident.t -> module_type -> t -> t
-val set_nongen_level: t -> int -> t
val for_saving: t -> t
val reset_for_saving: unit -> unit
| Texp_let (rec_flag, list, exp) ->
let (rec_flag, list) = sub.value_bindings sub (rec_flag, list) in
Texp_let (rec_flag, list, sub.expr sub exp)
- | Texp_function (l, cases, p) ->
- Texp_function (l, sub.cases sub cases, p)
+ | Texp_function { arg_label; param; cases; partial; } ->
+ Texp_function { arg_label; param; cases = sub.cases sub cases;
+ partial; }
| Texp_apply (exp, list) ->
Texp_apply (
sub.expr sub exp,
(mkctf (Tctf_inherit parent) :: fields,
val_sig, concr_meths, inher)
- | Pctf_val (lab, mut, virt, sty) ->
+ | Pctf_val ({txt=lab}, mut, virt, sty) ->
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 lab (mut, virt, ty) val_sig, concr_meths, inher)
- | Pctf_method (lab, priv, virt, sty) ->
+ | Pctf_method ({txt=lab}, priv, virt, sty) ->
let cty =
declare_method env meths self_type lab priv sty ctf.pctf_loc in
let concr_meths =
cl_sig.csig_concr []
in
(* Super *)
- let (val_env, met_env, par_env) =
+ let (val_env, met_env, par_env,super) =
match super with
None ->
- (val_env, met_env, par_env)
- | Some name ->
+ (val_env, met_env, par_env,None)
+ | Some {txt=name} ->
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
in
- (val_env, met_env, par_env)
+ (val_env, met_env, par_env,Some name)
in
(val_env, met_env, par_env,
lazy (mkcf (Tcf_inherit (ovf, parent, super, inh_vars, inh_meths)))
Printtyp.reset_and_mark_loops_list [params; cstrs];
fprintf ppf
"@[The abbreviation %a@ is used with parameters@ %a@ \
- wich are incompatible with constraints@ %a@]"
+ which are incompatible with constraints@ %a@]"
Printtyp.ident id Printtyp.type_expr params Printtyp.type_expr cstrs
| Class_match_failure error ->
Includeclass.report_error ppf error
| Tpat_array _ | Tpat_lazy _ -> p.pat_type
let build_or_pat env loc lid =
- let path, decl = Typetexp.find_type env loc lid
+ let path, decl = Typetexp.find_type env lid.loc lid.txt
in
let tyl = List.map (fun _ -> newvar()) decl.type_params in
let row0 =
let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in
match ty.desc with
Tvariant row when static_row row -> row
- | _ -> raise(Error(loc, env, Not_a_variant_type lid))
+ | _ -> raise(Error(lid.loc, env, Not_a_variant_type lid.txt))
in
let pats, fields =
List.fold_left
pats
in
match pats with
- [] -> raise(Error(loc, env, Not_a_variant_type lid))
+ [] -> raise(Error(lid.loc, env, Not_a_variant_type lid.txt))
| pat :: pats ->
let r =
List.fold_left
let nv = newvar () in
unify_pat_types loc !env (instance_def (Predef.type_lazy_t nv))
expected_ty;
- type_pat sp1 nv (fun p1 ->
+ (* do not explode under lazy: PR#7421 *)
+ type_pat ~explode:0 sp1 nv (fun p1 ->
rp k {
pat_desc = Tpat_lazy p1;
pat_loc = loc; pat_extra=[];
pat_extra = extra :: p.pat_extra}
in k p)
| Ppat_type lid ->
- let (path, p,ty) = build_or_pat !env loc lid.txt in
+ let (path, p,ty) = build_or_pat !env loc lid in
unify_pat_types loc !env ty expected_ty;
k { p with pat_extra =
(Tpat_type (path, lid), loc, sp.ppat_attributes) :: p.pat_extra }
with Not_found -> ()
end; iter_ppat (loop env) p
| Ppat_open (lid,sub_p) ->
- let _, new_env = !type_open Asttypes.Fresh env p.ppat_loc lid in
+ let _, new_env = !type_open Asttypes.Override env p.ppat_loc lid in
loop new_env sub_p
| _ -> iter_ppat (loop env) p
in
in
aux exp.exp_extra
+(* To find reasonable names for let-bound and lambda-bound idents *)
+
+let rec name_pattern default = function
+ [] -> Ident.create default
+ | {c_lhs=p; _} :: rem ->
+ match p.pat_desc with
+ Tpat_var (id, _) -> id
+ | Tpat_alias(_, id, _) -> id
+ | _ -> name_pattern default rem
+
(* Typing of expressions *)
let unify_exp env exp expected_ty =
match sexp.pexp_desc with
| Pexp_ident lid ->
begin
- let (path, desc) = Typetexp.find_value env loc lid.txt in
+ let (path, desc) = Typetexp.find_value env lid.loc lid.txt in
if !Clflags.annotations then begin
let dloc = desc.Types.val_loc in
let annot =
| Some exp ->
let ty_exp = instance env exp.exp_type in
let unify_kept lbl =
+ let _, ty_arg1, ty_res1 = instance_label false lbl in
+ unify_exp_types exp.exp_loc env ty_exp ty_res1;
match matching_label lbl with
| lid, _lbl, lbl_exp ->
+ (* do not connect result types for overridden labels *)
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
+ let _, 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
exp_extra = (Texp_coerce (cty, cty'), loc, sexp.pexp_attributes) ::
arg.exp_extra;
}
- | Pexp_send (e, met) ->
+ | Pexp_send (e, {txt=met}) ->
if !Clflags.principal then begin_def ();
let obj = type_exp env e in
let obj_meths = ref None in
Undefined_method (obj.exp_type, met, valid_methods)))
end
| Pexp_new cl ->
- let (cl_path, cl_decl) = Typetexp.find_class env loc cl.txt in
+ let (cl_path, cl_decl) = Typetexp.find_class env cl.loc cl.txt in
begin match cl_decl.cty_new with
None ->
raise(Error(loc, env, Virtual_class cl.txt))
in
re { exp with exp_extra =
(Texp_poly cty, loc, sexp.pexp_attributes) :: exp.exp_extra }
- | Pexp_newtype(name, sbody) ->
+ | Pexp_newtype({txt=name}, sbody) ->
let ty = newvar () in
(* remember original level *)
begin_def ();
if is_optional l && not_function ty_res then
Location.prerr_warning (List.hd cases).c_lhs.pat_loc
Warnings.Unerasable_optional_argument;
+ let param = name_pattern "param" cases in
re {
- exp_desc = Texp_function(l,cases, partial);
+ exp_desc = Texp_function { arg_label = l; param; cases; partial; };
exp_loc = loc; exp_extra = [];
exp_type = instance env (newgenty (Tarrow(l, ty_arg, ty_res, Cok)));
exp_attributes = attrs;
(texp,
args @ [Nolabel, Some eta_var])}
in
+ let cases = [case eta_pat e] in
+ let param = name_pattern "param" cases in
{ texp with exp_type = ty_fun; exp_desc =
- Texp_function(Nolabel, [case eta_pat e], Total) }
+ Texp_function { arg_label = Nolabel; param; cases;
+ partial = Total; } }
in
Location.prerr_warning texp.exp_loc
(Warnings.Eliminated_optional_arguments
val reset_delayed_checks: unit -> unit
val force_delayed_checks: unit -> unit
+val name_pattern : string -> Typedtree.case list -> Ident.t
+
val self_coercion : (Path.t * Location.t list ref) list ref
type error =
(* Enter all declared types in the environment as abstract types *)
-let enter_type env sdecl id =
+let enter_type rec_flag env sdecl id =
+ let needed =
+ match rec_flag with
+ | Asttypes.Nonrecursive -> Btype.is_row_name (Ident.name id)
+ | Asttypes.Recursive -> true
+ in
+ if not needed then env else
let decl =
{ type_params =
List.map (fun _ -> Btype.newgenvar ()) sdecl.ptype_params;
| _ -> Some ty
let get_unboxed_type_representation env ty =
- get_unboxed_type_representation env ty 100000
+ (* Do not give too much fuel: PR#7424 *)
+ get_unboxed_type_representation env ty 100
;;
(* Determine if a type's values are represented by floats at run-time. *)
widen z;
targs, Some tret_type, args, Some ret_type
+(* Check that the variable [id] is present in the [univ] list. *)
+let check_type_var loc univ id =
+ let f t = (Btype.repr t).id = id in
+ if not (List.exists f univ) then raise (Error (loc, Wrong_unboxed_type_float))
+
+(* Check that all the variables found in [ty] are in [univ].
+ Because [ty] is the argument to an abstract type, the representation
+ of that abstract type could be any subexpression of [ty], in particular
+ any type variable present in [ty].
+*)
+let rec check_unboxed_abstract_arg loc univ ty =
+ match ty.desc with
+ | Tvar _ -> check_type_var loc univ ty.id
+ | Tarrow (_, t1, t2, _)
+ | Tfield (_, _, t1, t2) ->
+ check_unboxed_abstract_arg loc univ t1;
+ check_unboxed_abstract_arg loc univ t2
+ | Ttuple args
+ | Tconstr (_, args, _)
+ | Tpackage (_, _, args) ->
+ List.iter (check_unboxed_abstract_arg loc univ) args
+ | Tobject (fields, r) ->
+ check_unboxed_abstract_arg loc univ fields;
+ begin match !r with
+ | None -> ()
+ | Some (_, args) -> List.iter (check_unboxed_abstract_arg loc univ) args
+ end
+ | Tnil
+ | Tunivar _ -> ()
+ | Tlink e -> check_unboxed_abstract_arg loc univ e
+ | Tsubst _ -> assert false
+ | Tvariant { row_fields; row_more; row_name } ->
+ List.iter (check_unboxed_abstract_row_field loc univ) row_fields;
+ check_unboxed_abstract_arg loc univ row_more;
+ begin match row_name with
+ | None -> ()
+ | Some (_, args) -> List.iter (check_unboxed_abstract_arg loc univ) args
+ end
+ | Tpoly (t, _) -> check_unboxed_abstract_arg loc univ t
+
+and check_unboxed_abstract_row_field loc univ (_, field) =
+ match field with
+ | Rpresent (Some ty) -> check_unboxed_abstract_arg loc univ ty
+ | Reither (_, args, _, r) ->
+ List.iter (check_unboxed_abstract_arg loc univ) args;
+ begin match !r with
+ | None -> ()
+ | Some f -> check_unboxed_abstract_row_field loc univ ("", f)
+ end
+ | Rabsent
+ | Rpresent None -> ()
+
(* 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 =
+ the type, given the universal parameters of the type. *)
+let rec check_unboxed_gadt_arg loc univ 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 = Tvar _; id} -> check_type_var loc univ id
| Some {desc = Tarrow _ | Ttuple _ | Tpackage _ | Tobject _ | Tnil
| Tvariant _; _} ->
()
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
+ List.iter (check_unboxed_abstract_arg loc univ) args
| Some {desc = Tfield _ | Tlink _ | Tsubst _; _} -> assert false
| Some {desc = Tunivar _; _} -> ()
- | Some {desc = Tpoly (t2, _); _} -> check_unboxed_gadt_arg loc ex env t2
+ | Some {desc = Tpoly (t2, _); _} -> check_unboxed_gadt_arg loc univ 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
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. *)
+ might be an existential type variable.
+ There is a difficulty with existential variables created
+ out of thin air (rather than bound by the declaration).
+ See PR#7511 and GPR#1133 for details. *)
match Datarepr.constructor_existentials args ret_type with
| _, [] -> ()
- | [argty], ex -> check_unboxed_gadt_arg sdecl.ptype_loc ex env argty
+ | [argty], _ex ->
+ check_unboxed_gadt_arg sdecl.ptype_loc params env argty
| _ -> assert false
end;
let tcstr =
Ctype.begin_def();
(* Enter types. *)
let temp_env =
- match rec_flag with
- | Asttypes.Nonrecursive -> env
- | Asttypes.Recursive -> List.fold_left2 enter_type env sdecl_list id_list
- in
+ List.fold_left2 (enter_type rec_flag) env sdecl_list id_list in
(* Translate each declaration. *)
let current_slot = ref None in
let warn_unused = Warnings.is_active (Warnings.Unused_type_declaration "") in
in
args, ret_type, Text_decl(targs, tret_type)
| Pext_rebind lid ->
- let cdescr = Typetexp.find_constructor env sext.pext_loc lid.txt in
+ let cdescr = Typetexp.find_constructor env lid.loc lid.txt in
let usage =
if cdescr.cstr_private = Private || priv = Public
then Env.Positive else Env.Privatize
reset_type_variables();
Ctype.begin_def();
let (type_path, type_decl) =
- Typetexp.find_type env loc styext.ptyext_path.txt
+ let lid = styext.ptyext_path in
+ Typetexp.find_type env lid.loc lid.txt
in
begin
match type_decl.type_kind with
Texp_ident of Path.t * Longident.t loc * Types.value_description
| Texp_constant of constant
| Texp_let of rec_flag * value_binding list * expression
- | Texp_function of arg_label * case list * partial
+ | Texp_function of { arg_label : arg_label; param : Ident.t;
+ cases : case list; partial : partial; }
| Texp_apply of expression * (arg_label * expression option) list
| Texp_match of expression * case list * case list * partial
| Texp_try of expression * case list
(** let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive)
let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive)
*)
- | Texp_function of arg_label * case list * partial
+ | Texp_function of { arg_label : arg_label; param : Ident.t;
+ cases : case list; partial : partial; }
(** [Pexp_fun] and [Pexp_function] both translate to [Texp_function].
See {!Parsetree} for more details.
+ [param] is the identifier that is to be used to name the
+ parameter of the function.
+
partial =
[Partial] if the pattern match is partial
[Total] otherwise.
| Texp_let (rec_flag, list, exp) ->
iter_bindings rec_flag list;
iter_expression exp
- | Texp_function (_label, cases, _) ->
+ | Texp_function { cases; _ } ->
iter_cases cases
| Texp_apply (exp, list) ->
iter_expression exp;
Texp_let (rec_flag,
map_bindings list,
map_expression exp)
- | Texp_function (label, cases, partial) ->
- Texp_function (label, map_cases cases, partial)
+ | Texp_function { arg_label; param; cases; partial; } ->
+ Texp_function { arg_label; param; cases = map_cases cases; partial; }
| Texp_apply (exp, list) ->
Texp_apply (map_expression exp,
List.map (fun (label, expo) ->
Mty_signature sg -> sg
| Mty_alias(_, path) ->
raise(Error(loc, env, Cannot_scrape_alias path))
- | _ -> raise(Error(loc, env, Structure_expected mty))
+ | mty -> raise(Error(loc, env, Structure_expected mty))
(* Compute the environment after opening a module *)
let env =
match row_id with
| None -> env
- | Some id -> Env.add_type ~check:true id newdecl env
+ | Some id -> Env.add_type ~check:false id newdecl env
in
let env = if rs = Trec_not then env else add_rec_types env rem in
Includemod.type_declarations env id newdecl decl;
}
and id_row = Ident.create (s^"#row") in
let initial_env =
- Env.add_type ~check:true id_row decl_row initial_env
+ Env.add_type ~check:false id_row decl_row initial_env
in
let tdecl = Typedecl.transl_with_constraint
initial_env id (Some(Pident id_row)) decl sdecl in
md_loc = pmb_loc;
}
in
+ (*prerr_endline (Ident.unique_toplevel_name id);*)
+ Mtype.lower_nongen (Ident.binding_time id - 1) md.md_type;
let newenv = Env.enter_module_declaration id md env in
Tstr_module {mb_id=id; mb_name=name; mb_expr=modl;
mb_attributes=attrs; mb_loc=pmb_loc;
case, the inferred signature contains only the last declaration. *)
if not !Clflags.dont_write_files then begin
let deprecated = Builtin_attributes.deprecated_of_str ast in
- let sg =
+ let cmi =
Env.save_signature ~deprecated
simple_sg modulename (outputprefix ^ ".cmi")
in
Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename
(Cmt_format.Implementation str)
- (Some sourcefile) initial_env (Some sg);
+ (Some sourcefile) initial_env (Some cmi);
end;
(str, coercion)
end
(Env.imports()) in
(* Write packaged signature *)
if not !Clflags.dont_write_files then begin
- let sg =
+ let cmi =
Env.save_signature_with_imports ~deprecated:None
sg modulename
(prefix ^ ".cmi") imports
in
Cmt_format.save_cmt (prefix ^ ".cmt") modulename
- (Cmt_format.Packed (sg, objfiles)) None initial_env (Some sg)
+ (Cmt_format.Packed (cmi.Cmi_format.cmi_sign, objfiles)) None initial_env (Some cmi)
end;
Tcoerce_none
end
val save_signature:
string -> Typedtree.signature -> string -> string ->
- Env.t -> Types.signature_item list -> unit
+ Env.t -> Cmi_format.cmi_infos -> unit
val package_units:
Env.t -> string list -> string -> string -> Typedtree.module_coercion
let ty = newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys)) in
ctyp (Ttyp_tuple ctys) ty
| Ptyp_constr(lid, stl) ->
- let (path, decl) = find_type env styp.ptyp_loc lid.txt in
+ let (path, decl) = find_type env lid.loc lid.txt in
let stl =
match stl with
| [ {ptyp_desc=Ptyp_any} as t ] when decl.type_arity > 1 ->
ctyp (Ttyp_constr (path, lid, args)) constr
| Ptyp_object (fields, o) ->
let fields =
- List.map (fun (s, a, t) -> (s, a, transl_poly_type env policy t))
+ List.map (fun (s, a, t) -> (s.txt, a, transl_poly_type env policy t))
fields
in
let ty = newobj (transl_fields loc env policy [] o fields) 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
+ ignore (find_class env lid.loc lid.txt); assert false
in
if List.length stl <> decl.type_arity then
raise(Error(styp.ptyp_loc, env,
in
let ty = newty (Tvariant row) in
ctyp (Ttyp_variant (tfields, closed, present)) ty
- | Ptyp_poly(vars, st) ->
+ | Ptyp_poly(vars, st) ->
+ let vars = List.map (fun v -> v.txt) vars in
begin_def();
let new_univars = List.map (fun name -> name, newvar ~name ()) vars in
let old_univars = !univars in
fprintf ppf "Multiple constraints for type %a" longident s
| Repeated_method_label s ->
fprintf ppf "@[This is the second method `%s' of this object type.@ %s@]"
- s "Multiple occurences are not allowed."
+ s "Multiple occurrences are not allowed."
| Unbound_value lid ->
fprintf ppf "Unbound value %a" longident lid;
spellcheck ppf fold_values env lid;
| Texp_open (ovf, _path, lid, _) ->
Pexp_open (ovf, map_loc sub lid, sexp)
| Texp_poly cto -> Pexp_poly (sexp, map_opt (sub.typ sub) cto)
- | Texp_newtype s -> Pexp_newtype (s, sexp)
+ | Texp_newtype s -> Pexp_newtype (mkloc s loc, sexp)
in
Exp.mk ~loc ~attrs desc
(* Pexp_function can't have a label, so we split in 3 cases. *)
(* One case, no guard: It's a fun. *)
- | Texp_function (label, [{c_lhs=p; c_guard=None; c_rhs=e}], _) ->
- Pexp_fun (label, None, sub.pat sub p, sub.expr sub e)
+ | Texp_function { arg_label; cases = [{c_lhs=p; c_guard=None; c_rhs=e}];
+ _ } ->
+ Pexp_fun (arg_label, None, sub.pat sub p, sub.expr sub e)
(* No label: it's a function. *)
- | Texp_function (Nolabel, cases, _) ->
+ | Texp_function { arg_label = Nolabel; cases; _; } ->
Pexp_function (sub.cases sub cases)
(* Mix of both, we generate `fun ~label:$name$ -> match $name$ with ...` *)
- | Texp_function (Labelled s | Optional s as label, cases, _) ->
+ | Texp_function { arg_label = Labelled s | Optional s as label; cases;
+ _ } ->
let name = fresh_name s exp.exp_env in
Pexp_fun (label, None, Pat.var ~loc {loc;txt = name },
Exp.match_ ~loc (Exp.ident ~loc {loc;txt= Lident name})
dir, sub.expr sub exp3)
| Texp_send (exp, meth, _) ->
Pexp_send (sub.expr sub exp, match meth with
- Tmeth_name name -> name
- | Tmeth_val id -> Ident.name id)
+ Tmeth_name name -> mkloc name loc
+ | Tmeth_val id -> mkloc (Ident.name id) loc)
| Texp_new (_path, lid, _) -> Pexp_new (map_loc sub lid)
| Texp_instvar (_, path, name) ->
Pexp_ident ({loc = sub.location sub name.loc ; txt = lident_of_path path})
let desc = match ctf.ctf_desc with
Tctf_inherit ct -> Pctf_inherit (sub.class_type sub ct)
| Tctf_val (s, mut, virt, ct) ->
- Pctf_val (s, mut, virt, sub.typ sub ct)
+ Pctf_val (mkloc s loc, mut, virt, sub.typ sub ct)
| Tctf_method (s, priv, virt, ct) ->
- Pctf_method (s, priv, virt, sub.typ sub ct)
+ Pctf_method (mkloc s loc, priv, virt, sub.typ sub ct)
| Tctf_constraint (ct1, ct2) ->
Pctf_constraint (sub.typ sub ct1, sub.typ sub ct2)
| Tctf_attribute x -> Pctf_attribute x
List.map (sub.typ sub) list)
| Ttyp_object (list, o) ->
Ptyp_object
- (List.map (fun (s, a, t) -> (s, a, sub.typ sub t)) list, o)
+ (List.map (fun (s, a, t) ->
+ (mkloc s loc, a, sub.typ sub t)) list, o)
| Ttyp_class (_path, lid, list) ->
Ptyp_class (map_loc sub lid, List.map (sub.typ sub) list)
| Ttyp_alias (ct, s) ->
Ptyp_alias (sub.typ sub ct, s)
| Ttyp_variant (list, bool, labels) ->
Ptyp_variant (List.map (sub.row_field sub) list, bool, labels)
- | Ttyp_poly (list, ct) -> Ptyp_poly (list, sub.typ sub ct)
+ | Ttyp_poly (list, ct) ->
+ let list = List.map (fun v -> mkloc v loc) list in
+ Ptyp_poly (list, sub.typ sub ct)
| Ttyp_package pack -> Ptyp_package (sub.package_type sub pack)
in
Typ.mk ~loc ~attrs desc
let attrs = sub.attributes sub cf.cf_attributes in
let desc = match cf.cf_desc with
Tcf_inherit (ovf, cl, super, _vals, _meths) ->
- Pcf_inherit (ovf, sub.class_expr sub cl, super)
+ Pcf_inherit (ovf, sub.class_expr sub cl,
+ map_opt (fun v -> mkloc v loc) super)
| Tcf_constraint (cty, cty') ->
Pcf_constraint (sub.typ sub cty, sub.typ sub cty')
| Tcf_val (lab, mut, _, Tcfk_virtual cty, _) ->
Pcf_method (lab, priv, Cfk_virtual (sub.typ sub cty))
| Tcf_method (lab, priv, Tcfk_concrete (o, exp)) ->
let remove_fun_self = function
- | { exp_desc = Texp_function(Nolabel, [case], _) }
+ | { exp_desc =
+ Texp_function { arg_label = Nolabel; cases = [case]; _ } }
when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs
| e -> e
in
Pcf_method (lab, priv, Cfk_concrete (o, sub.expr sub exp))
| Tcf_initializer exp ->
let remove_fun_self = function
- | { exp_desc = Texp_function(Nolabel, [case], _) }
+ | { exp_desc =
+ Texp_function { arg_label = Nolabel; cases = [case]; _ } }
when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs
| e -> e
in
then display_msvc_output file name;
exit
+let macos_create_empty_archive ~quoted_archive =
+ let result =
+ command (Printf.sprintf "%s rc %s /dev/null" Config.ar quoted_archive)
+ in
+ if result <> 0 then result
+ else
+ let result =
+ command (Printf.sprintf "%s %s 2> /dev/null" Config.ranlib quoted_archive)
+ in
+ if result <> 0 then result
+ else
+ command (Printf.sprintf "%s d %s /dev/null" Config.ar quoted_archive)
+
let create_archive archive file_list =
Misc.remove_file archive;
let quoted_archive = Filename.quote archive in
quoted_archive (quote_files file_list))
| _ ->
assert(String.length Config.ar > 0);
- let r1 =
- command(Printf.sprintf "%s rc %s %s"
- Config.ar quoted_archive (quote_files file_list)) in
- if r1 <> 0 || String.length Config.ranlib = 0
- then r1
- else command(Config.ranlib ^ " " ^ quoted_archive)
+ let is_macosx =
+ match Config.system with
+ | "macosx" -> true
+ | _ -> false
+ in
+ if is_macosx && file_list = [] then (* PR#6550 *)
+ macos_create_empty_archive ~quoted_archive
+ else
+ let r1 =
+ command(Printf.sprintf "%s rc %s %s"
+ Config.ar quoted_archive (quote_files file_list)) in
+ if r1 <> 0 || String.length Config.ranlib = 0
+ then r1
+ else command(Config.ranlib ^ " " ^ quoted_archive)
let expand_libname name =
if String.length name < 2 || String.sub name 0 2 <> "-l"
let classic_inlining = ref false (* -Oclassic *)
let inlining_report = ref false (* -inlining-report *)
+let afl_instrument = ref Config.afl_instrument (* -afl-instrument *)
+let afl_inst_ratio = ref 100 (* -afl-inst-ratio *)
+
let simplify_rounds = ref None (* -rounds *)
let default_simplify_rounds = ref 1 (* -rounds *)
let rounds () =
| "always" -> Some Misc.Color.Always
| "never" -> Some Misc.Color.Never
| _ -> None
-let color = ref Misc.Color.Auto ;; (* -color *)
+let color = ref None ;; (* -color *)
let unboxed_types = ref false
+
+let arg_spec = ref []
+let arg_names = ref Misc.StringMap.empty
+let add_arguments loc args =
+ List.iter (function (arg_name, _, _) as arg ->
+ try
+ let loc2 = Misc.StringMap.find arg_name !arg_names in
+ Printf.eprintf
+ "Warning: plugin argument %s is already defined:\n" arg_name;
+ Printf.eprintf " First definition: %s\n" loc2;
+ Printf.eprintf " New definition: %s\n" loc;
+ with Not_found ->
+ arg_spec := !arg_spec @ [ arg ];
+ arg_names := Misc.StringMap.add arg_name loc !arg_names
+ ) args
+
+let print_arguments usage =
+ Arg.usage !arg_spec usage
+
+(* This function is almost the same as [Arg.parse_expand], except
+ that [Arg.parse_expand] could not be used because it does not take a
+ reference for [arg_spec].*)
+let parse_arguments f msg =
+ try
+ let argv = ref Sys.argv in
+ let current = ref (!Arg.current) in
+ Arg.parse_and_expand_argv_dynamic current argv arg_spec f msg
+ with
+ | Arg.Bad msg -> Printf.eprintf "%s" msg; exit 2
+ | Arg.Help msg -> Printf.printf "%s" msg; exit 0
val remove_unused_arguments : bool ref
val dump_flambda_verbose : bool ref
val classic_inlining : bool ref
+val afl_instrument : bool ref
+val afl_inst_ratio : int ref
val all_passes : string list ref
val dumped_pass : string -> bool
val set_dumped_pass : string -> bool -> unit
val parse_color_setting : string -> Misc.Color.setting option
-val color : Misc.Color.setting ref
+val color : Misc.Color.setting option ref
val unboxed_types : bool ref
+
+val arg_spec : (string * Arg.spec * string) list ref
+
+(* [add_arguments __LOC__ args] will add the arguments from [args] at
+ the end of [arg_spec], checking that they have not already been
+ added by [add_arguments] before. A warning is printed showing the
+ locations of the function from which the argument was previously
+ added. *)
+val add_arguments : string -> (string * Arg.spec * string) list -> unit
+
+(* [parse_arguments anon_arg usage] will parse the arguments, using
+ the arguments provided in [Clflags.arg_spec]. It allows plugins to
+ provide their own arguments.
+*)
+val parse_arguments : Arg.anon_fun -> string -> unit
+
+val print_arguments : string -> unit
val systhread_supported : bool
(* Whether the system thread library is implemented *)
+val flexdll_dirs : string list
+ (* Directories needed for the FlexDLL objects *)
+
val host : string
(* Whether the compiler is a cross-compiler *)
val print_config : out_channel -> unit;;
+val profiling : bool
+ (* Whether profiling with gprof is supported on this platform *)
+
val flambda : bool
(* Whether the compiler was configured for flambda *)
val spacetime : bool
(* Whether the compiler was configured for Spacetime profiling *)
+val profinfo : bool
+ (* Whether the compiler was configured for profiling *)
val profinfo_width : int
(* How many bits are to be used in values' headers for profiling
information *)
val safe_string: bool
(* Whether the compiler was configured with -safe-string *)
+val afl_instrument : bool
+ (* Whether afl-fuzz instrumentation is generated by default *)
(* *)
(**************************************************************************)
-(***********************************************************************)
-(** **)
-(** WARNING WARNING WARNING **)
-(** **)
-(** When you change this file, you must make the parallel change **)
-(** in config.mlbuild **)
-(** **)
-(***********************************************************************)
-
-
(* The main OCaml version string has moved to ../VERSION *)
let version = Sys.ocaml_version
let standard_runtime = "%%BYTERUN%%"
let ccomp_type = "%%CCOMPTYPE%%"
-let bytecomp_c_compiler = "%%BYTECC%%"
+let bytecomp_c_compiler = "%%BYTECODE_C_COMPILER%%"
let bytecomp_c_libraries = "%%BYTECCLIBS%%"
-let native_c_compiler = "%%NATIVECC%%"
+let native_c_compiler = "%%NATIVE_C_COMPILER%%"
let native_c_libraries = "%%NATIVECCLIBS%%"
let native_pack_linker = "%%PACKLD%%"
let ranlib = "%%RANLIBCMD%%"
else
"%%MKDLL%%", "%%MKEXE%%", "%%MKMAINDLL%%"
+let profiling = %%PROFILING%%
let flambda = %%FLAMBDA%%
let safe_string = %%SAFE_STRING%%
+let afl_instrument = %%AFL_INSTRUMENT%%
+
let exec_magic_number = "Caml1999X011"
and cmi_magic_number = "Caml1999I021"
and cmo_magic_number = "Caml1999O011"
and ast_impl_magic_number = "Caml1999M020"
and ast_intf_magic_number = "Caml1999N018"
and cmxs_magic_number = "Caml2007D002"
-and cmt_magic_number = "Caml2012T008"
+and cmt_magic_number = "Caml2012T009"
let load_path = ref ([] : string list)
let spacetime = %%WITH_SPACETIME%%
let libunwind_available = %%LIBUNWIND_AVAILABLE%%
let libunwind_link_flags = "%%LIBUNWIND_LINK_FLAGS%%"
+let profinfo = %%WITH_PROFINFO%%
let profinfo_width = %%PROFINFO_WIDTH%%
+let ext_exe = "%%EXT_EXE%%"
let ext_obj = "%%EXT_OBJ%%"
let ext_asm = "%%EXT_ASM%%"
let ext_lib = "%%EXT_LIB%%"
let systhread_supported = %%SYSTHREAD_SUPPORT%%;;
+let flexdll_dirs = [%%FLEXDLL_DIR%%];;
+
let print_config oc =
let p name valu = Printf.fprintf oc "%s: %s\n" name valu in
+ let p_int name valu = Printf.fprintf oc "%s: %d\n" name valu in
let p_bool name valu = Printf.fprintf oc "%s: %B\n" name valu in
p "version" version;
p "standard_library_default" standard_library_default;
p "cc_profile" cc_profile;
p "architecture" architecture;
p "model" model;
+ p_int "int_size" Sys.int_size;
+ p_int "word_size" Sys.word_size;
p "system" system;
p "asm" asm;
p_bool "asm_cfi_supported" asm_cfi_supported;
p_bool "with_frame_pointers" with_frame_pointers;
+ p "ext_exe" ext_exe;
p "ext_obj" ext_obj;
p "ext_asm" ext_asm;
p "ext_lib" ext_lib;
p_bool "systhread_supported" systhread_supported;
p "host" host;
p "target" target;
+ p_bool "profiling" profiling;
p_bool "flambda" flambda;
p_bool "spacetime" spacetime;
p_bool "safe_string" safe_string;
let of_list l =
List.fold_left (fun map (id, v) -> add id v map) empty l
- let disjoint_union ?eq m1 m2 =
+ let disjoint_union ?eq ?print m1 m2 =
union (fun id v1 v2 ->
let ok = match eq with
| None -> false
| Some eq -> eq v1 v2
in
if not ok then
- let err = Format.asprintf "Map.disjoint_union %a" T.print id in
+ let err =
+ match print with
+ | None ->
+ Format.asprintf "Map.disjoint_union %a" T.print id
+ | Some print ->
+ Format.asprintf "Map.disjoint_union %a => %a <> %a"
+ T.print id print v1 print v2
+ in
Misc.fatal_error err
else Some v1)
m1 m2
val filter_map : 'a t -> f:(key -> 'a -> 'b option) -> 'b t
val of_list : (key * 'a) list -> 'a t
- val disjoint_union : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> 'a t
+ val disjoint_union : ?eq:('a -> 'a -> bool) -> ?print:(Format.formatter -> 'a -> unit) -> 'a t -> 'a t -> 'a t
val union_right : 'a t -> 'a t -> 'a t
val union_left : 'a t -> 'a t -> 'a t
val union_merge : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t
(** [disjoint_union m1 m2] contains all bindings from [m1] and
[m2]. If some binding is present in both and the associated
value is not equal, a Fatal_error is raised *)
- val disjoint_union : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> 'a t
+ val disjoint_union : ?eq:('a -> 'a -> bool) -> ?print:(Format.formatter -> 'a -> unit) -> 'a t -> 'a t -> 'a t
(** [union_right m1 m2] contains all bindings from [m1] and [m2]. If
some binding is present in both, the one from [m2] is taken *)
Format.set_mark_tags true;
List.iter set_color_tag_handling formatter_l;
color_enabled := (match o with
- | Always -> true
- | Auto -> should_enable_color ()
- | Never -> false
- )
+ | Some Always -> true
+ | Some Auto -> should_enable_color ()
+ | Some Never -> false
+ | None -> should_enable_color ())
);
()
end
(* [no_overflow_add n1 n2] returns [true] if the computation of
[n1 + n2] does not overflow. *)
val no_overflow_sub: int -> int -> bool
- (* [no_overflow_add n1 n2] returns [true] if the computation of
+ (* [no_overflow_sub n1 n2] returns [true] if the computation of
[n1 - n2] does not overflow. *)
val no_overflow_mul: int -> int -> bool
(* [no_overflow_mul n1 n2] returns [true] if the computation of
does not occur. *)
val replace_substring: before:string -> after:string -> string -> string
- (* [search_substring ~before ~after str] replaces all
- occurences of [before] with [after] in [str] and returns
+ (* [replace_substring ~before ~after str] replaces all
+ occurrences of [before] with [after] in [str] and returns
the resulting string. *)
val rev_split_words: string -> string list
type setting = Auto | Always | Never
- val setup : setting -> unit
+ val setup : setting option -> unit
(* [setup opt] will enable or disable color handling on standard formatters
according to the value of color setting [opt].
Only the first call to this function has an effect. *)
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]. *)
+ not be wrapped into a {!HookExnWrapper}. *)
module type HookSig = sig
type t
(* *)
(**************************************************************************)
-(** Modules about numbers that satisfy [Identifiable.S]. *)
+(** Modules about numbers that satisfy {!Identifiable.S}. *)
module Int : sig
include Identifiable.S with type t = int
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* Nicolas Ojeda Bar, LexiFi *)
+(* *)
+(* 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. *)
+(* *)
+(**************************************************************************)
+
+type repr =
+ | Int32 of int32
+ | Int64 of int64
+
+module type S = sig
+ type t
+ val zero : t
+ val one : t
+ val minus_one : t
+ val neg : t -> t
+ val add : t -> t -> t
+ val sub : t -> t -> t
+ val mul : t -> t -> t
+ val div : t -> t -> t
+ val rem : t -> t -> t
+ val succ : t -> t
+ val pred : t -> t
+ val abs : t -> t
+ val max_int : t
+ val min_int : t
+ val logand : t -> t -> t
+ val logor : t -> t -> t
+ val logxor : t -> t -> t
+ val lognot : t -> t
+ val shift_left : t -> int -> t
+ val shift_right : t -> int -> t
+ val shift_right_logical : t -> int -> t
+ val of_int : int -> t
+ val of_int_exn : int -> t
+ val to_int : t -> int
+ val of_float : float -> t
+ val to_float : t -> float
+ val of_int32 : int32 -> t
+ val to_int32 : t -> int32
+ val of_int64 : int64 -> t
+ val to_int64 : t -> int64
+ val of_string : string -> t
+ val to_string : t -> string
+ val compare: t -> t -> int
+ val equal: t -> t -> bool
+ val repr: t -> repr
+end
+
+let size = Sys.word_size
+(* Later, this will be set by the configure script
+ in order to support cross-compilation. *)
+
+module Int32 = struct
+ include Int32
+ let of_int_exn =
+ match Sys.word_size with (* size of [int] *)
+ | 32 ->
+ Int32.of_int
+ | 64 ->
+ fun n ->
+ if n < Int32.(to_int min_int) || n > Int32.(to_int max_int) then
+ Misc.fatal_errorf "Targetint.of_int_exn: 0x%x out of range" n
+ else
+ Int32.of_int n
+ | _ ->
+ assert false
+ let of_int32 x = x
+ let to_int32 x = x
+ let of_int64 = Int64.to_int32
+ let to_int64 = Int64.of_int32
+ let repr x = Int32 x
+end
+
+module Int64 = struct
+ include Int64
+ let of_int_exn = Int64.of_int
+ let of_int64 x = x
+ let to_int64 x = x
+ let repr x = Int64 x
+end
+
+include (val
+ (match size with
+ | 32 -> (module Int32)
+ | 64 -> (module Int64)
+ | _ -> assert false
+ ) : S)
--- /dev/null
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* Nicolas Ojeda Bar, LexiFi *)
+(* *)
+(* 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. *)
+(* *)
+(**************************************************************************)
+
+(** Target processor-native integers.
+
+ This module provides operations on the type of
+ signed 32-bit integers (on 32-bit target platforms) or
+ signed 64-bit integers (on 64-bit target platforms).
+ This integer type has exactly the same width as that of a
+ pointer type in the C compiler. All arithmetic operations over
+ are taken modulo 2{^32} or 2{^64} depending
+ on the word size of the target architecture.
+*)
+
+type t
+(** The type of target integers. *)
+
+val zero : t
+(** The target integer 0.*)
+
+val one : t
+(** The target integer 1.*)
+
+val minus_one : t
+(** The target integer -1.*)
+
+val neg : t -> t
+(** Unary negation. *)
+
+val add : t -> t -> t
+(** Addition. *)
+
+val sub : t -> t -> t
+(** Subtraction. *)
+
+val mul : t -> t -> t
+(** Multiplication. *)
+
+val div : t -> t -> t
+(** Integer division. Raise [Division_by_zero] if the second
+ argument is zero. This division rounds the real quotient of
+ its arguments towards zero, as specified for {!Pervasives.(/)}. *)
+
+val rem : t -> t -> t
+(** Integer remainder. If [y] is not zero, the result
+ of [Targetint.rem x y] satisfies the following properties:
+ [Targetint.zero <= Nativeint.rem x y < Targetint.abs y] and
+ [x = Targetint.add (Targetint.mul (Targetint.div x y) y)
+ (Targetint.rem x y)].
+ If [y = 0], [Targetint.rem x y] raises [Division_by_zero]. *)
+
+val succ : t -> t
+(** Successor.
+ [Targetint.succ x] is [Targetint.add x Targetint.one]. *)
+
+val pred : t -> t
+(** Predecessor.
+ [Targetint.pred x] is [Targetint.sub x Targetint.one]. *)
+
+val abs : t -> t
+(** Return the absolute value of its argument. *)
+
+val size : int
+(** The size in bits of a target native integer. *)
+
+val max_int : t
+(** The greatest representable target integer,
+ either 2{^31} - 1 on a 32-bit platform,
+ or 2{^63} - 1 on a 64-bit platform. *)
+
+val min_int : t
+(** The smallest representable target integer,
+ either -2{^31} on a 32-bit platform,
+ or -2{^63} on a 64-bit platform. *)
+
+val logand : t -> t -> t
+(** Bitwise logical and. *)
+
+val logor : t -> t -> t
+(** Bitwise logical or. *)
+
+val logxor : t -> t -> t
+(** Bitwise logical exclusive or. *)
+
+val lognot : t -> t
+(** Bitwise logical negation *)
+
+val shift_left : t -> int -> t
+(** [Targetint.shift_left x y] shifts [x] to the left by [y] bits.
+ The result is unspecified if [y < 0] or [y >= bitsize],
+ where [bitsize] is [32] on a 32-bit platform and
+ [64] on a 64-bit platform. *)
+
+val shift_right : t -> int -> t
+(** [Targetint.shift_right x y] shifts [x] to the right by [y] bits.
+ This is an arithmetic shift: the sign bit of [x] is replicated
+ and inserted in the vacated bits.
+ The result is unspecified if [y < 0] or [y >= bitsize]. *)
+
+val shift_right_logical : t -> int -> t
+(** [Targetint.shift_right_logical x y] shifts [x] to the right
+ by [y] bits.
+ This is a logical shift: zeroes are inserted in the vacated bits
+ regardless of the sign of [x].
+ The result is unspecified if [y < 0] or [y >= bitsize]. *)
+
+val of_int : int -> t
+(** Convert the given integer (type [int]) to a target integer
+ (type [t]), module the target word size. *)
+
+val of_int_exn : int -> t
+(** Convert the given integer (type [int]) to a target integer
+ (type [t]). Raises a fatal error if the conversion is not exact. *)
+
+val to_int : t -> int
+(** Convert the given target integer (type [t]) to an
+ integer (type [int]). The high-order bit is lost during
+ the conversion. *)
+
+val of_float : float -> t
+(** Convert the given floating-point number to a target integer,
+ discarding the fractional part (truncate towards 0).
+ The result of the conversion is undefined if, after truncation,
+ the number is outside the range
+ \[{!Targetint.min_int}, {!Targetint.max_int}\]. *)
+
+val to_float : t -> float
+(** Convert the given target integer to a floating-point number. *)
+
+val of_int32 : int32 -> t
+(** Convert the given 32-bit integer (type [int32])
+ to a target integer. *)
+
+val to_int32 : t -> int32
+(** Convert the given target integer to a
+ 32-bit integer (type [int32]). On 64-bit platforms,
+ the 64-bit native integer is taken modulo 2{^32},
+ i.e. the top 32 bits are lost. On 32-bit platforms,
+ the conversion is exact. *)
+
+val of_int64 : int64 -> t
+(** Convert the given 64-bit integer (type [int64])
+ to a target integer. *)
+
+val to_int64 : t -> int64
+(** Convert the given target integer to a
+ 64-bit integer (type [int64]). *)
+
+val of_string : string -> t
+(** Convert the given string to a target integer.
+ The string is read in decimal (by default) or in hexadecimal,
+ octal or binary if the string begins with [0x], [0o] or [0b]
+ respectively.
+ Raise [Failure "int_of_string"] if the given string is not
+ a valid representation of an integer, or if the integer represented
+ exceeds the range of integers representable in type [nativeint]. *)
+
+val to_string : t -> string
+(** Return the string representation of its argument, in decimal. *)
+
+val compare: t -> t -> int
+(** The comparison function for target integers, with the same specification as
+ {!Pervasives.compare}. Along with the type [t], this function [compare]
+ allows the module [Targetint] to be passed as argument to the functors
+ {!Set.Make} and {!Map.Make}. *)
+
+val equal: t -> t -> bool
+(** The equal function for target ints. *)
+
+type repr =
+ | Int32 of int32
+ | Int64 of int64
+
+val repr : t -> repr
+(** The concrete representation of a native integer. *)
type compiler_pass =
| All
| Parsing of file
- | Preprocessing of file
+ | Parser of file
+ | Dash_pp of file
+ | Dash_ppx of file
| Typing of file
| Transl of file
| Generate of file
let timings : (compiler_pass, float * float option) Hashtbl.t =
Hashtbl.create 20
+external time_include_children: bool -> float = "caml_sys_time_include_children"
+let cpu_time () = time_include_children true
+
let reset () = Hashtbl.clear timings
let start pass =
(* Cannot assert it is not here: a source file can be compiled
multiple times on the same command line *)
(* assert(not (Hashtbl.mem timings pass)); *)
- let time = Sys.time () in
+ let time = cpu_time () in
Hashtbl.add timings pass (time, None)
let stop pass =
assert(Hashtbl.mem timings pass);
- let time = Sys.time () in
+ let time = cpu_time () in
let (start, stop) = Hashtbl.find timings pass in
assert(stop = None);
Hashtbl.replace timings pass (start, Some (time -. start))
-let time pass f x =
+let time_call pass f =
start pass;
- let r = f x in
+ let r = f () in
stop pass;
r
+let time pass f x = time_call pass (fun () -> f x)
+
let restart pass =
let previous_duration =
match Hashtbl.find timings pass with
| (_, Some duration) -> duration
| _, None -> assert false
in
- let time = Sys.time () in
+ let time = cpu_time () in
Hashtbl.replace timings pass (time, Some previous_duration)
let accumulate pass =
- let time = Sys.time () in
+ let time = cpu_time () in
match Hashtbl.find timings pass with
| exception Not_found -> assert false
| _, None -> assert false
let pass_name = function
| All -> "all"
| Parsing file -> Printf.sprintf "parsing(%s)" file
- | Preprocessing file -> Printf.sprintf "preprocessing(%s)" file
+ | Parser file -> Printf.sprintf "parser(%s)" file
+ | Dash_pp file -> Printf.sprintf "-pp(%s)" file
+ | Dash_ppx file -> Printf.sprintf "-ppx(%s)" file
| Typing file -> Printf.sprintf "typing(%s)" file
| Transl file -> Printf.sprintf "transl(%s)" file
| Generate file -> Printf.sprintf "generate(%s)" file
let timings_list () =
let l = Hashtbl.fold (fun pass times l -> (pass, times) :: l) timings [] in
- List.sort (fun (_, (start1, _)) (_, (start2, _)) -> compare start1 start2) l
+ List.sort (fun (pass1, (start1, _)) (pass2, (start2, _)) ->
+ compare (start1, pass1) (start2, pass2)) l
let print ppf =
- let current_time = Sys.time () in
+ let current_time = cpu_time () in
List.iter (fun (pass, (start, stop)) ->
match stop with
| Some duration ->
Format.fprintf ppf "%s: %.03fs@." (pass_name pass) duration
| None ->
- Format.fprintf ppf "%s: running since %.03fs@." (pass_name pass)
+ Format.fprintf ppf "%s: running for %.03fs@." (pass_name pass)
(current_time -. start))
(timings_list ())
type compiler_pass =
| All
| Parsing of file
- | Preprocessing of file
+ | Parser of file
+ | Dash_pp of file
+ | Dash_ppx of file
| Typing of file
| Transl of file
| Generate of file
val get : compiler_pass -> float option
(** returns the runtime in seconds of a completed pass *)
+val time_call : compiler_pass -> (unit -> 'a) -> 'a
+(** [time_call pass f] calls [f] and records its runtime. *)
+
val time : compiler_pass -> ('a -> 'b) -> 'a -> 'b
-(** [time pass f arg] Record the runtime of [f arg] *)
+(** [time pass f arg] records the runtime of [f arg] *)
val accumulate_time : compiler_pass -> ('a -> 'b) -> 'a -> 'b
(** Like time for passes that can run multiple times *)
CC=$(BYTECC)
CFLAGS=-DNDEBUG $(BYTECCCOMPOPTS)
+ifeq "$(TOOLCHAIN)" "mingw"
+ CFLAGS += -DNO_UNIX
+else ifeq "$(TOOLCHAIN)" "msvc"
+ CFLAGS += -DNO_UNIX
+endif
+
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)
$(MKEXE) -o ocamlyacc$(EXE) $(OBJS) $(EXTRALIBS)
version.h : ../VERSION
- echo "#define OCAML_VERSION \"`sed -e 1q ../VERSION`\"" >version.h
+ echo "#define OCAML_VERSION \"`sed -e 1q $^ | tr -d '\r'`\"" > $@
clean:
rm -f *.$(O) ocamlyacc$(EXE) *~ version.h
symtab.$(O): defs.h
verbose.$(O): defs.h
warshall.$(O): defs.h
+
+# The following rule is similar to make's default one, except that it
+# also works for .obj files.
+
+%.$(O): %.c
+ $(CC) $(CFLAGS) -c $<
#**************************************************************************
include Makefile
-
-%.$(O): %.c
- $(BYTECC) -DNDEBUG -DNO_UNIX $(BYTECCCOMPOPTS) -c $<
line = REALLOC(line, linesize);
if (line == 0) no_space();
}
- if (c == '\n') { line[i] = '\0'; cptr = line; return; }
+ if (c == '\n') {
+ if (i >= 2 && line[i-2] == '\r') {
+ line[i-2] = '\n'; i--;
+ }
+ line[i] = '\0'; cptr = line; return;
+ }
c = getc(f);
if (c == EOF) { saw_eof = 1; c = '\n'; }
}
projects / ocaml.git / commitdiff